home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / limit.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  84.7 KB  |  2,709 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module limit)
  13.  
  14.  
  15. ;;;    **************************************************************
  16. ;;;    **                                **
  17. ;;;    **               LIMIT PACKAGE            **
  18. ;;;    **                                **
  19. ;;;    **************************************************************
  20.  
  21.  
  22. ;;; TOP LEVEL FUNCTION(S): $LIMIT $LDEFINT
  23.  
  24. (DECLARE-TOP(GENPREFIX L)
  25.      (SPECIAL ERRORSW errrjfflag raterr ORIGVAL $LHOSPITALLIM LOW*
  26.           IND* *INDICATOR LIMFUNC 
  27.           HALF%PI NN* DN* numer denom EXP VAR VAL VARLIST
  28.           *ZEXPTSIMP? $TLIMSWITCH ORIGVAL
  29.           $LOGARC *LIMORDER TAYLORED LOGCOMBED
  30.           $EXPONENTIALIZE LHP? LHCOUNT
  31.           $RATFAC GENVAR COMPLEX-LIMIT LNORECURSE
  32.           LOGINPROD? $LIMSUBST $LOGABS A 
  33.           context global-assumptions limit-assumptions
  34.           limit-top limitp integer-info old-integer-info
  35.           behavior-count behavior-count-now $KEEPFLOAT $logexpand)
  36.      (*LEXPR $LIMIT limit-list $FACTOR FACTOR $EXPAND
  37.          $RATSIMP $RAT $RATCOEF context)
  38.      (*expr $trigexpand)
  39.      (FIXNUM NARGS BEHAVIOR-COUNT BEHAVIOR-COUNT-NOW))
  40.  
  41. (load-macsyma-macros rzmac)
  42.  
  43. (DEFMVAR INFINITIES '($INF $MINF $INFINITY) 
  44.   "The types of infinities recognized by Macsyma. 
  45.    INFINITY is complex infinity")
  46.  
  47. (DEFMVAR REAL-INFINITIES '($INF $MINF)
  48.   "The real infinities, INF is positive infinity, MINF negative infinity")
  49.  
  50. (DEFMVAR INFINITESIMALS '($ZEROA $ZEROB)
  51.   "The infinitesimals recognized by Macsyma. ZEROA zero from above,
  52.    ZEROB zero from below")
  53.  
  54. (defmvar RD* NIL
  55.   "The full implications of this flag have yet to be determined.
  56. It appears in LIMIT and DEFINT.......")
  57.  
  58. (defmvar simplimplus-problems ()
  59.   "A list of all problems in the stack of recursive calls to simplimplus.")
  60.  
  61. (defmvar limit-answers ()
  62.   "An association list for storing limit answers.")
  63.  
  64. (defmvar preserve-direction () "Makes LIMIT return Direction info.")
  65.  
  66. (if (not (boundp 'integer-info)) (setq integer-info ()))
  67.  
  68. (if (not (boundp 'behavior-count)) (setq behavior-count 4))
  69.  
  70. ;; This should be made to give more information about the error.
  71. ;(DEFun DISCONT () 
  72. ;       (cond (errorsw (throw 'errorsw t))
  73. ;         (t (merror "Discontinuity Encountered"))))
  74.  
  75. ;(DEFUN PUTLIMVAL (E V) 
  76. ;  (let ((exp (cons '(%limit) (list e var val))))
  77. ;    (cond ((not (assolike exp limit-answers))
  78. ;       (setq limit-answers (cons (cons exp v) limit-answers))
  79. ;       v)
  80. ;      (t ()))))
  81.  
  82. (defun putlimval (e v &aux exp)
  83.   (setq exp `((%limit) ,e ,var ,val))
  84.   (unless (assolike exp limit-answers)
  85.     (setq limit-answers (cons (cons exp v) limit-answers)))
  86.   v)
  87.  
  88. (DEFun GETLIMVAL (E) 
  89.   (let ((exp (cons '(%limit) (list e var val))))
  90.     (assolike exp limit-answers)))
  91.  
  92. (DEFMACRO LIMIT-CATCH (EXP VAR VAL) 
  93.  `(LET ((ERRORSW T))
  94.     (LET ((ANS (CATCH 'ERRORSW 
  95.           (CATCH 'LIMIT (LIMIT ,EXP ,VAR ,VAL 'THINK)))))
  96.     (COND ((OR (NULL ANS) (EQ ANS T))  ())
  97.           (T ANS)))))
  98.  
  99. (defmfun $limit nargs
  100. (let ((global-assumptions ())  (limit-assumptions ())
  101.       (old-integer-info ())
  102.       ($keepfloat t)  (limit-top t))
  103.      (DECLARE (special global-assumptions limit-assumptions old-integer-info
  104.       $keepfloat  limit-top t))
  105.   (if (not limitp)
  106.       (progn (setq old-integer-info integer-info)
  107.          (setq integer-info ())))
  108.  
  109.   (unwind-protect
  110.    (let ((exp1 ()) (rd* t) (lhcount $lhospitallim) (behavior-count-now 0)     
  111.          (d ()) (exp ()) (var ()) (val ()) (dr ()) 
  112.          (*indicator ()) (taylored ()) (origval ())
  113.      (logcombed ()) (lhp? ()) ($logexpand t)
  114.      (varlist ()) (ans ()) (genvar ()) (loginprod? ()) 
  115.      (limit-answers ()) (limitp t) (simplimplus-problems ()))
  116.      (declare (special lhcount behaviour-count-now exp var val *indicator taylored origval logcombed lhp?
  117.      $logexpand varlist genvar loginprod? limitp ))
  118.      (prog ()
  119.        (if (not (or (= nargs 3) (= nargs 4) (= nargs 1))) (wna-err '$limit))
  120. ;;;Is it a LIST of Things?
  121.        (if (setq ans (apply #'limit-list (listify nargs))) (return ans))
  122.        (setq exp1 (specrepcheck (arg 1)))
  123.        (cond ((= nargs 1) (setq var 'foo val 0))
  124.          (t (setq var (arg 2))
  125.         (cond (($constantp var) 
  126.                (merror 
  127.             "Second argument cannot be a constant - LIMIT")))
  128.         (setq val (arg 3))
  129.         (if (eq val '$zeroa) (setq dr '$plus))
  130.         (if (eq val '$zerob) (setq dr '$minus))))
  131.        (cond ((= nargs 4)
  132.           (if (not (memq (arg 4) '($plus $minus)))
  133.           (merror
  134.            "Fourth argument must be either PLUS or MINUS - LIMIT"))
  135.           (setq dr (arg 4))))
  136.        (cond ((and (atom var) (not (among var val)))
  137.           (setq exp exp1))
  138. ;;;Var is funny so make it a gensym.
  139.          (t (let ((realvar var))
  140.              (setq var (gensym))
  141.              (setq exp (MAXIMA-SUBSTITUTE var realvar exp1))
  142.              (putprop var realvar 'limitsub))))
  143.        (if (and (not $limsubst) (not (eq var 'foo)))
  144.        (if (limunknown exp)
  145.            (return `((%limit) ,@(cons exp1 (cdr (listify nargs)))))))
  146.        (setq varlist (ncons var) genvar nil origval val)
  147. ;;;Limit is going to want to make its own assumptions about the variable
  148. ;;;based on what the calling program knows. Old assumptions are saved
  149. ;;;for restoration upon exit.
  150.        (if (not (= nargs 1)) (limit-context (arg 2) origval dr))
  151. ;;;Transform the limit value.         
  152.        (cond ((not (infinityp val))
  153.           (if (not (zerop2 val))
  154.           (setq exp (subin (m+ var val) exp)))
  155.           (setq val (cond ((eq dr '$plus) '$zeroa)
  156.                   ((eq dr '$minus) '$zerob)
  157.                   (t 0)))
  158.           (setq origval 0)))
  159.        (if (eq val '$minf) (setq val '$inf 
  160.                  origval '$inf
  161.                  exp (subin (m* -1 var) exp)))
  162.        (setq exp (resimplify
  163.           (factosimp (tansc (lfibtophi
  164.                      (limitsimp ($expand (hide exp) 1 0)
  165.                         var))))))
  166. ;;;Resimplify in light of new assumptions.
  167.        (setq d (catch 'mabs (mabs-subst exp var val)))
  168.        (cond ((eq d 'both) (or (setq ans (both-side exp var val))
  169.                    (nounlimit exp var val)))
  170.          ((eq d '$und) (return '$und))
  171.          ((eq d 'retn) (return (nounlimit exp var val)))
  172.          (t (setq exp d)))
  173.        (setq ans (limit-catch exp var val))
  174.        (cond ((null ans)
  175.           (if (or (real-epsilonp val)
  176.               (real-infinityp val))
  177.           (return (nounlimit exp var val))))
  178.          (t (return (clean-limit-exp ans))))
  179.        (cond ((setq ans (both-side exp var val))
  180.           (return (clean-limit-exp ans)))
  181.          (t (return (nounlimit exp var val))))))
  182.    (restore-assumptions))))
  183.  
  184. (defun clean-limit-exp (exp)
  185.   (setq exp (restorelim exp))
  186.   (if preserve-direction exp (ridofab exp)))
  187.  
  188. (defmfun limit-list nargs
  189.        (let (((exp1 . rest) (listify nargs)))
  190.         (cond ((mbagp exp1)
  191.            `(,(car exp1) ,@(mapcar
  192.                     #'(lambda (x)
  193.                           (apply '$limit `(,x ,@rest)))
  194.                     (cdr exp1))))
  195.           (t ()))))
  196.  
  197. (defun limit-context (var val direction) ;Only works on entry!
  198.  (cond (limit-top 
  199.     (mapc 'forget (setq global-assumptions (cdr ($facts var))))
  200.     (assume '((mgreaterp) epsilon 0))
  201.     (assume '((mlessp) epsilon 1.0e-8))
  202.     (assume '((mgreaterp) prin-inf 1.0e+8))
  203.     (setq limit-assumptions
  204.           (make-limit-assumptions global-assumptions var val direction))
  205.     (setq limit-top ()))
  206.        (t ()))
  207.  limit-assumptions)
  208.  
  209. (defun make-limit-assumptions (old-assumptions var val direction)
  210.   (prog (new-assumptions)
  211.   (setq new-assumptions (use-old-context old-assumptions var val))
  212.   (mapc #'assume new-assumptions)
  213.   (if (or (null var) (null val)) (return ()))
  214.   (cond ((and (not (infinityp val)) (null direction)) (return ()))
  215.     ((eq val '$inf)
  216.      (setq new-assumptions `(,(assume `((mgreaterp) ,var 1.0e+8))
  217.                  ,@new-assumptions))
  218.      (return new-assumptions))
  219.     ((eq val '$minf)
  220.      (setq new-assumptions `(,(assume `((mgreaterp) 1.0e+8 ,var))
  221.                  ,@new-assumptions))
  222.      (return new-assumptions))
  223.     ((eq direction '$plus)
  224.      (setq new-assumptions `(,(assume `((mgreaterp) ,var 0)) ;All limits
  225.                  ,@new-assumptions))             ;around 0
  226.      (return new-assumptions))
  227.     ((eq direction '$minus)
  228.      (setq new-assumptions `(,(assume `((mgreaterp) 0 ,var))
  229.                  ,@new-assumptions))
  230.      (return new-assumptions))
  231.     (t (return ())))))
  232.  
  233. (defun use-old-context (old-assumptions var val)
  234.    (setq var (ridofab var))
  235.    (cond ((null old-assumptions) ())
  236.      ((not (infinityp val))
  237.       (do ((list old-assumptions (cdr list))
  238.            (pred) (part1) (part2) (assumptions))
  239.           ((null list) assumptions)
  240.         (setq pred (caar (car list))
  241.           part1 (cadr (car list))
  242.           part2 (caddr (car list)))
  243.         (if (memq pred '(mgreaterp mlessp))
  244.         (push (make-assump pred part1 part2 var val) 
  245.               assumptions))))))
  246.  
  247. (defun make-assump (pred part1 part2 var val)
  248.   (cond ((eq part1 var)
  249.      (cond ((and (free part2 '$inf)
  250.              (free part2 '$minf)
  251.              (free part2 '$infinity))
  252.         `((,pred) ,part1 ,(m+t part2 (m*t -1 val))))
  253.            (t `((,pred) ,part1 ,part2))))
  254.     ((eq part2 var)
  255.      (cond ((and (free part1 '$inf)
  256.              (free part1 '$minf)
  257.              (free part1 '$infinity))
  258.         `((,pred) ,(m+t part1 (m*t -1 val)) ,part2))
  259.            (t `((,pred) ,part1 ,part2))))))
  260.         
  261. (defun restore-assumptions ()
  262. ;;;Hackery until assume and forget take reliable args. Nov. 9 1979.
  263. ;;;JIM.
  264.        (do ((assumption-list limit-assumptions (cdr assumption-list)))
  265.        ((null assumption-list) t)
  266.        (forget (car assumption-list)))
  267.        (forget '((mgreaterp) epsilon 0))
  268.        (forget '((mlessp) epsilon 1.0e-8))
  269.        (forget '((mgreaterp) prin-inf 1.0e+8))
  270.        (cond ((and (not (null integer-info))
  271.            (not limitp))
  272.           (do ((list integer-info (cdr list)))
  273.           ((null list) t)
  274.           (I-$remove `(,(cadar list) ,(caddar list))))
  275.           (setq integer-info old-integer-info)))
  276.        (do ((assumption-list global-assumptions (cdr assumption-list)))
  277.        ((null assumption-list) t)
  278.        (assume (car assumption-list))))
  279.  
  280. (DEFUN BOTH-SIDE (EXP VAR VAL)
  281.   (let ((preserve-direction t))
  282.     (let ((la ($LIMIT EXP VAR VAL '$PLUS))
  283.       (lb ($LIMIT EXP VAR VAL '$MINUS)))
  284.       (cond ((ALIKE1 (ridofab LA) (ridofab LB))  (ridofab la))
  285.         ((and (not (free la '%limit))
  286.           (not (free la '%limit)))  ())
  287.         (t '$und)))))
  288.  
  289. ;; Warning:  (CATCH NIL ...) will catch all throws.
  290. ;; NIL should not be used as a tag name.
  291.  
  292. (DEFUN LIMUNKNOWN (F) (CATCH 'limunknown (LIMUNKNOWN1 (SPECREPCHECK F))))
  293.  
  294. (DEFUN LIMUNKNOWN1 (F)
  295.        (COND ((mapatom f) nil)
  296.          ((OR (NOT (safe-GET (CAAR F) 'OPERATORS))
  297.           (MEMQ (CAAR F) '(%SUM %PRODUCT %SIGNUM MNCEXPT))
  298. ;Special function code here i.e. for li[2](x).
  299.           (and (eq (caar f) 'mqapply)
  300.                (not (get (subfunname f) 'specsimp))))
  301.           (IF (NOT (FREE F VAR)) (THROW 'limunknown T)))
  302.          (T (MAPC #'LIMUNKNOWN1 (CDR F)) NIL)))
  303.  
  304. (DEFUN FACTOSIMP(E)
  305.        (IF (INVOLVE E '(%GAMMA)) (SETQ E ($MAKEFACT E))) 
  306.        (COND ((INVOLVE E '(MFACTORIAL))
  307.           (SETQ E (SIMPLIFY ($MINFACTORIAL E))))
  308.          (T E)))
  309.  
  310. (DEFUN GETSIGNL (Z)
  311.   (let ((z (ridofab z)))
  312.     (if (not (free z var)) (setq z ($limit z var val)))
  313.     (let ((sign ($asksign z)))
  314.       (cond ((eq sign '$pos) 1)
  315.         ((eq sign '$neg) -1)
  316.         ((eq sign '$zero) 0)))))
  317.  
  318. (defun restorelim (exp)
  319.        (cond ((null exp) nil)
  320.          ((atom exp) (or (and (symbolp exp) (get exp 'limitsub)) exp))
  321.          ((and (consp (car exp)) (eq (caar exp) 'mrat))
  322.           (cons (car exp)
  323.             (cons (restorelim (cadr exp))
  324.               (restorelim (cddr exp)))))
  325.          (t (cons (car exp) (mapcar #'restorelim (cdr exp))))))
  326.  
  327.  
  328. (DEFUN MABS-SUBST (EXP VAR VAL)    ; RETURNS EXP WITH MABS REMOVED, OR THROWS.
  329.  (let ((d (involve exp '(mabs))))
  330.    (cond ((null d) exp)
  331.      (t (cond
  332.          ((not (and (equal ($imagpart (limit d var val 'think)) 0)
  333.             (equal ($imagpart var) 0))) (throw 'mabs 'retn))
  334.          (t (DO ((ANS D (INVOLVE EXP '(MABS))) (a () ()))
  335.             ((NULL ANS) EXP)
  336.           (SETQ A (MABS-SUBST ANS VAR VAL))
  337.           (SETQ D (LIMIT A VAR VAL T))
  338.           (cond 
  339.            ((or (null a) (null d))
  340.             (if (not (OR (eq val '$zeroa)
  341.                  (eq val '$zerob)
  342.                  (REAL-INFINITYP VAL)))  (THROW 'MABS 'BOTH)))
  343.            ((AND A D)
  344.             (COND ((ZEROP1 D)  (SETQ D (BEHAVIOR A VAR VAL))
  345.                        (if (ZEROP1 D) (THROW 'MABS 'RETN))))
  346.             (if (OR (EQ D '$ZEROA) (EQ D '$INF) (RATGREATERP D 0))
  347.             (SETQ EXP (MAXIMA-SUBSTITUTE A `((MABS) ,ANS) EXP)))
  348.             (if (OR (EQ D '$ZEROB) (EQ D '$MINF) (RATGREATERP 0 D))
  349.             (SETQ EXP (MAXIMA-SUBSTITUTE (M* -1 A) `((MABS) ,ANS) EXP)))
  350.             (if (EQ D '$UND) (THROW 'MABS '$UND)))
  351.            (t (THROW 'MABS 'RETN))))))))))
  352.  
  353. (DEFUN INFCOUNT (EXP)
  354.        (COND ((ATOM EXP)
  355.           (COND ((INFINITYP EXP) 1)
  356.             (T 0)))
  357.          (T (f+ (INFCOUNT (CAR EXP)) (INFCOUNT (CDR EXP))))))
  358.  
  359. (DEFUN SIMPINF (EXP)
  360.  (declare (SPECIAL exp val))
  361.   (LET ((INFC (INFCOUNT EXP)) NEXP)
  362.     (COND
  363.      ((= INFC 0)  EXP)
  364.      ((= INFC 1)  (SETQ INFC (inf-typep exp))
  365.           ($LIMIT (SUBST VAR INFC EXP) VAR INFC))
  366.      (t 
  367.       (SETQ NEXP (CONS (CAR EXP) (MAPCAR 'SIMPINF (CDR EXP))))
  368.       (SETQ INFC (INFCOUNT NEXP))
  369.       (cond
  370.        ((AMONG '$UND NEXP)  '$UND)
  371.        ((AMONGL '(%LIMIT $IND) NEXP)  EXP)
  372.        ((mtimesp nexp)
  373.     (COND ((zl-MEMBER 0 NEXP)
  374.            (COND ((> INFC 0) '$UND)
  375.              (T 0)))
  376.           ((MEMQ '$INFINITY NEXP) '$INFINITY)
  377.           (T (SIMPLIMIT NEXP VAR VAL))))
  378.        ((mexptp nexp)
  379.     (COND ((AND (EQ (CADR NEXP) '$INF) (EQ (CADDR NEXP) '$INF)) '$INF)
  380.           (T (SIMPINF (m^ '$%E (m* (CADDR EXP) `((%LOG) ,(CADR EXP))))))))
  381.        ((< INFC 2)  (SIMPINF NEXP))
  382.        ((mplusp nexp)
  383.     (COND ((MEMQ '$INFINITY (CDR NEXP)) '$INFINITY)
  384.           (T (SETQ INFC (inf-typep nexp))
  385.          (COND 
  386.           ((AMONGL (zl-DELETE INFC 
  387.                    (copy-top-level '($infinity $minf inf)))
  388.                NEXP)
  389.            '$UND)
  390.           (T INFC)))))
  391.        (T NEXP))))))
  392.  
  393. (defun simpab (small)
  394.    (cond ((null small) ())
  395.      ((memq small '($zeroa $zerob $inf $minf $infinity)) small)
  396.      ((not (free small '$ind)) '$ind) ;Not exactly right but not
  397.      ((not (free small '$und)) '$und) ;causing trouble now.
  398.      ((mapatom small)  small)
  399.      ((and (not (free-infp small))
  400.            (or (not (free small '$zeroa))
  401.            (not (free small '$zerob))))
  402.       (throw 'limit t)) ;Terrible loss, can do better
  403.      (t (let ((preserve-direction t)
  404.           (new-small (subst 'epsilon '$zeroa 
  405.                     (subst (m- 'epsilon) '$zerob small))))
  406.           (limit new-small 'epsilon '$zeroa 'think)))))
  407.  
  408.  
  409. ;;;*I* INDICATES: T => USE LIMIT1,THINK, NIL => USE SIMPLIMIT.
  410. (DEFMFUN LIMIT (EXP VAR VAL *I*) 
  411.   (COND
  412.    ((AMONG '$UND EXP)  '$UND)
  413.    ((EQ VAR EXP)  VAL)
  414.    ((ATOM EXP)  EXP)
  415.    ((NOT (AMONG VAR EXP))
  416.     (COND ((AMONGL '($INF $MINF $INFINITY $IND) EXP)
  417.        (SIMPINF EXP))
  418.       (T EXP)))
  419.    ((GETLIMVAL EXP))
  420.    (T (PUTLIMVAL EXP (COND ((AND $TLIMSWITCH
  421.                  (NULL TAYLORED)
  422.                  (TLIMP EXP))
  423.                 (TAYLIM EXP *I*))
  424.                ((RATP EXP VAR) (RATLIM EXP))
  425.                ((OR (EQ *I* T) (RADICALP EXP VAR))
  426.                 (LIMIT1 EXP VAR VAL))
  427.                ((EQ *I* 'THINK)        
  428.                 (COND ((or (mtimesp exp) (mexptp exp))
  429.                    (LIMIT1 EXP VAR VAL))
  430.                   (T (SIMPLIMIT EXP VAR VAL))))
  431.                (T (SIMPLIMIT EXP VAR VAL)))))))
  432.       
  433. (defun limitsimp (exp var)
  434.    (limitsimp-dispatch (sin-sq-cos-sq-sub exp) var))
  435. ;Hack for sin(x)^2+cos(x)^2.
  436.  
  437. (defun limitsimp-dispatch (exp var)
  438.   (cond ((or (atom exp)
  439.          (mnump exp)
  440.          (freeof var exp))   exp)
  441.     ((mexptp exp)
  442.      (limitsimp-expt exp var))
  443.     (t (subst0 (cons (cons (caar exp) ())
  444.              (mapcar #'(lambda (x)
  445.                      (limitsimp-dispatch x var))
  446.                  (cdr exp)))
  447.             exp))))
  448.  
  449.  
  450. (defun limitsimp-expt (exp var)
  451.   (cond ((and (mexptp exp)
  452.           (not (freeof var (cadr exp)))
  453.           (not (freeof var (caddr exp))))
  454.      (m^ '$%e (simplify `((%log) ,exp))))
  455.     (t exp)))
  456.  
  457. (defun sin-sq-cos-sq-sub (exp) ;Hack ... Hack
  458.   (let ((arg (involve exp '(%sin %cos))))
  459.     (cond
  460.      ((null arg) exp)
  461.      (t (let ((new-exp ($substitute (m+t 1 (m- (m^t `((%sin) ,arg) 2)))
  462.                     (m^t `((%cos) ,arg) 2)
  463.                     ($substitute 
  464.                      (m+t 1 (m- (m^t `((%cos) ,arg) 2)))
  465.                       (m^t `((%sin) ,arg) 2)
  466.                       exp))))
  467.          (cond ((not (involve new-exp '(%sin %cos)))  new-exp)
  468.            (t exp)))))))
  469.  
  470. (defun expand-trigs (x var)
  471.        (cond ((atom x) x)
  472.          ((mnump x) x)
  473.          ((and (or (eq (caar x) '%sin)
  474.                (eq (caar x) '%cos))
  475.            (not (free (cadr x) var)))
  476.           ($trigexpand x))
  477.          (t (simplify (cons (ncons (caar x))
  478.                 (mapcar #'(lambda (x)
  479.                          (expand-trigs x var))
  480.                     (cdr x)))))))
  481.  
  482.  
  483. (DEFUN TANSC (E) 
  484.   (COND ((NOT (INVOLVE E
  485.                '(%COT %CSC %BINOMIAL
  486.                   %SEC %COTH %SECH %CSCH
  487.                   %ACOT %ACSC %ASEC %ACOTH
  488.                   %ASECH %ACSCH
  489.                   %jacobi_ns %jacobi_nc %jacobi_cs
  490.                   %jacobi_ds %jacobi_dc)))
  491.      E)
  492.     (T ($RATSIMP (TANSC1 E))))) 
  493.  
  494. (DEFUN TANSC1 (E &aux tem)
  495.   (COND ((ATOM E) E)
  496.     ((AND (SETQ E (CONS (CAR E) (MAPCAR 'TANSC1 (CDR E))))  ()))
  497.     ((SETQ TEM (ASSQ (CAAR E) '((%COT . %TAN) (%COTH . %TANH)
  498.                     (%SEC . %COS) (%SECH . %COSH)
  499.                     (%CSC . %SIN) (%CSCH . %SINH))))
  500.      (TANSC1 (m^ (LIST (NCONS (CDR TEM)) (CADR E)) -1.)))
  501.     ((SETQ TEM (ASSQ (CAAR E) '((%jacobi_nc . %jacobi_cn)
  502.                     (%jacobi_ns . %jacobi_sn)
  503.                     (%jacobi_cs . %jacobi_sc)
  504.                     (%jacobi_ds . %jacobi_sd)
  505.                     (%jacobi_dc . %jacobi_cd))))
  506.      ;; Converts Jacobi elliptic function to its reciprocal
  507.      ;; function.
  508.      (TANSC1 (m^ (LIST (NCONS (CDR TEM)) (CADR E) (third e)) -1.)))
  509.     ((SETQ TEM (MEMQ (CAAR E) '(%SINH %COSH %TANH)))
  510.      (let (($EXPONENTIALIZE t)) 
  511.        (RESIMPLIFY E)))
  512.     ((SETQ TEM (ASSQ (CAAR E) '((%ACSC . %ASIN) (%ASEC . %ACOS)
  513.                     (%ACOT . %ATAN) (%ACSCH . %ASINH)
  514.                     (%ASECH . %ACOSH) (%ACOTH . %ATANH))))
  515.      (LIST (NCONS (CDR TEM)) (m^t (CADR E) -1.)))
  516.     ((AND (EQ (CAAR E) '%BINOMIAL) (AMONG VAR (CDR E)))
  517.      (m//  `((MFACTORIAL) ,(CADR E))
  518.            (m* `((MFACTORIAL) ,(m+t (CADR E) (m- (CADDR E))))
  519.            `((MFACTORIAL) ,(CADDR E)))))
  520.     (t E)))
  521.  
  522. (DEFUN HYPEREX (EX) 
  523.        (COND ((NOT (INVOLVE EX
  524.                 '(%SIN %COS %TAN %ASIN %ACOS %ATAN
  525.                   %SINH %COSH %TANH %ASINH %ACOSH %ATANH)))
  526.           EX)
  527.          (T (HYPEREX0 EX)))) 
  528.  
  529. (DEFUN HYPEREX0 (EX) 
  530.        (COND ((ATOM EX) EX)
  531.          ((eq (caar ex) '%sinh)
  532.           (m// (m+ (m^ '$%e (cadr ex)) (m- (m^ '$%e (m- (cadr ex)))))
  533.            2))
  534.          ((eq (caar ex) '%cosh)
  535.           (m// (m+ (m^ '$%e (cadr ex)) (m^ '$%e (m- (cadr ex))))
  536.            2))
  537.          ((AND (MEMQ (CAAR EX)
  538.              '(%SIN %COS %TAN %ASIN %ACOS %ATAN %SINH
  539.                %COSH %TANH %ASINH %ACOSH %ATANH))
  540.            (AMONG VAR EX))
  541.           (HYPEREX1 EX))
  542.          (T (CONS (CAR EX) (MAPCAR #'HYPEREX0 (CDR EX)))))) 
  543.  
  544. (DEFUN HYPEREX1 (EX) 
  545.   (LET ( ;; Can't exponentialize now because complex plane isn't handled right yet
  546.       ;; ($EXPONENTIALIZE T)
  547.      ($LOGARC T))
  548.     (SSIMPLIFYA EX)))
  549.  
  550. ;Used by tlimit also.
  551. (DEFMFUN LIMIT1 (EXP VAR VAL) 
  552.        (prog ()
  553.        (let ((lhprogress? lhp?)  (lhp? ())  (ans ()))
  554.         (COND ((SETQ ans (AND (NOT (ATOM EXP))
  555.                   (GETLIMVAL EXP))) 
  556.            (RETURN ans))
  557.           ((and (not (INFINITYP VAL))
  558.             (SETQ ans (SIMPLIMSUBST VAL EXP)))
  559.            (RETURN ans))
  560.           (t nil))
  561.  
  562. ;;;NUMDEN* => (numerator . denominator)         
  563.         (LET (((n . dn) (NUMDEN* EXP)))    
  564.          (COND
  565.           ((NOT (AMONG VAR DN))
  566.            (RETURN (SIMPLIMIT (M// (SIMPLIMIT N VAR VAL) DN) 
  567.                       VAR
  568.                       VAL)))
  569.           ((NOT (AMONG VAR N))
  570.            (RETURN (SIMPLIMIT (M* N
  571.                       (SIMPLIMEXPT DN
  572.                                -1.
  573.                                (SIMPLIMIT DN
  574.                                   VAR
  575.                                   VAL)
  576.                                -1.))
  577.                       VAR
  578.                       VAL)))
  579.           ((AND (RADICALP N VAR) (RADICALP DN VAR))
  580.            (RETURN (RADLIM (m* N (m^ DN -1.))
  581.                    N
  582.                    DN)))
  583.           ((AND LHPROGRESS?
  584.             (/#ALIKE N (CAR LHPROGRESS?))
  585.             (/#ALIKE DN (CDR LHPROGRESS?)))
  586.            (THROW 'LHOSPITAL NIL)))
  587.          (RETURN (LIMIT2 N DN VAR VAL))))))
  588.  
  589. (DEFUN /#ALIKE (E F)
  590.        (cond ((ALIKE1 E F)
  591.           t)
  592.          (t (let ((deriv (sdiff (m// e f) var)))
  593.              (cond ((=0 deriv)
  594.                 t)
  595.                ((=0 ($ratsimp deriv))
  596.                 t)
  597.                (t nil))))))
  598.  
  599. ;(DECLARE (SPECIAL N DN)) 
  600.  
  601. (DEFUN LIMIT2 (N DN VAR VAL)
  602.   (PROG (N1 D1 lim-SIGN GCP SHEUR-ANS)
  603.     (setq n (hyperex n) dn (hyperex dn))
  604. ;;;Change to uniform limit call.
  605.     (COND ((INFINITYP VAL)  (SETQ D1 (LIMIT DN VAR VAL NIL))
  606.                 (SETQ N1 (LIMIT N VAR VAL NIL)))
  607.       (T (COND ((SETQ N1 (SIMPLIMSUBST VAL N)) NIL)
  608.            (T (SETQ N1 (LIMIT N VAR VAL NIL))))
  609.          (COND ((SETQ D1 (SIMPLIMSUBST VAL DN)) NIL)
  610.            (T (SETQ D1 (LIMIT DN VAR VAL NIL))))))
  611.     (COND ((OR (NULL N1) (NULL D1)) (RETURN NIL))
  612.       (T (SETQ N1 (SRATSIMP N1) D1 (SRATSIMP D1))))
  613.     (COND ((OR (INVOLVE N '(MFACTORIAL)) (INVOLVE DN '(MFACTORIAL)))
  614.        (let ((ANS (limfact2 n dn var val)))
  615.          (COND (ANS (RETURN ANS))))))
  616.     (COND ((AND (ZEROP2 N1) (ZEROP2 D1))
  617.        (COND  ((NOT (EQUAL (SETQ GCP (GCPOWER N DN)) 1))
  618.            (RETURN (COLEXPT N DN GCP)))
  619.           ((and (real-epsilonp val)
  620.             (not (free n '%log))
  621.             (not (free dn '%log)))
  622.            (return (liminv (m// n dn))))
  623.           ((SETQ N1 (TRY-LHOSPITAL-QUIT N DN NIL))
  624.            (RETURN N1))))
  625.       ((AND (ZEROP2 N1) (NOT (MEMQ D1 '($IND $UND)))) (RETURN 0))
  626.       ((ZEROP2 D1) 
  627.        (SETQ N1 (RIDOFAB N1))
  628.        (return (SIMPLIMTIMES `(,N1 ,(SIMPLIMEXPT DN -1 D1 -1))))))
  629.     (SETQ N1 (RIDOFAB N1))
  630.     (SETQ D1 (RIDOFAB D1))
  631.     (COND ((OR (EQ D1 '$UND)
  632.            (AND (EQ N1 '$UND) (NOT (REAL-INFINITYP D1))))
  633.        (RETURN '$UND))
  634.       ((EQ D1 '$IND) (RETURN '$UND))
  635.       ((EQ N1 '$IND) (RETURN (COND ((INFINITYP D1) 0)
  636.                        ((EQUAL D1 0) '$UND)
  637.                        (T '$IND)))) ;SET LB
  638.       ((AND (REAL-INFINITYP D1) (MEMQ N1 '($INF $UND $MINF)))
  639.        (COND ((EXPFACTORP N DN)  (RETURN (EXPFACTOR N DN VAR)))
  640.          ((AND (NOT (ATOM DN)) (NOT (ATOM N))
  641.                (COND ((NOT (EQUAL (SETQ GCP (GCPOWER N DN)) 1))
  642.                   (RETURN (COLEXPT N DN GCP)))
  643.                  ((AND (EQ '$INF VAL)
  644.                    (OR (INVOLVE DN '(MFACTORIAL %GAMMA))
  645.                        (INVOLVE N '(MFACTORIAL %GAMMA))))
  646.                   (RETURN (LIMFACT N DN))))))
  647.          ((EQ N1 D1) (SETQ LIM-SIGN 1) (GO CP))
  648.          (T (SETQ LIM-SIGN -1) (GO CP))))
  649.       ((AND (INFINITYP D1) (INFINITYP N1))
  650.        (SETQ LIM-SIGN (IF (OR (EQ D1 '$MINF) (EQ N1 '$MINF)) -1 1))
  651.        (GO CP))
  652.       (T (RETURN (SIMPLIMTIMES `(,N1 ,(m^ d1 -1))))))
  653. CP   (SETQ N ($EXPAND N) DN ($EXPAND DN))
  654.      (COND ((mplusp n)
  655.         (let ((MAXI-TERMS (maxi (cdr n))) (NEW-N ()))
  656.           (SETQ NEW-N (COND ((NOT (NULL (CDR MAXI-TERMS)))
  657.                  (m+l MAXI-TERMS))
  658.                 (T (CAR MAXI-TERMS))))
  659.           (COND ((NOT (ALIKE1 NEW-N N))
  660.              (RETURN (LIMIT (M// NEW-N DN) VAR '$INF 'THINK))))
  661.           (SETQ N1 (CAR MAXI-TERMS))))
  662.        (T (SETQ N1 N)))
  663.      (COND ((mplusp dn)
  664.         (let ((MAXI-TERMS (maxi (cdr dn)))
  665.           (NEW-DN ()))
  666.           (SETQ NEW-DN (COND ((NOT (NULL (CDR MAXI-TERMS)))
  667.                   (m+l MAXI-TERMS))
  668.                  (T (CAR MAXI-TERMS))))
  669.           (COND ((NOT (ALIKE1 NEW-DN DN))
  670.              (RETURN (LIMIT (M// N NEW-DN) VAR '$INF 'THINK))))
  671.           (SETQ D1 (CAR MAXI-TERMS))))
  672.        (T (SETQ D1 DN)))
  673.      (SETQ SHEUR-ANS (SHEUR0 N1 D1))
  674.      (COND ((or (MEMQ SHEUR-ANS '($INF $ZEROA))
  675.         (free sheur-ans var))
  676.         (RETURN (SIMPLIMTIMES `(,lim-SIGN ,SHEUR-ANS))))
  677.        ((AND (ALIKE1 SHEUR-ANS DN)
  678.          (NOT (mplusp n))))
  679.        ((MEMQ (SETQ N1 (cond ((expfactorp n1 d1)  (EXPFACTOR N1 D1 VAR))
  680.                  (t ())))
  681.           '($INF $ZEROA))
  682.         (RETURN N1))
  683.        ((NOT (NULL (SETQ N1 (cond ((expfactorp n dn)  (EXPFACTOR N DN VAR))
  684.                       (t ())))))
  685.         (RETURN N1))
  686.        ((AND (ALIKE1 SHEUR-ANS DN) (NOT (MPLUSP N))))
  687.        ((not (alike1 sheur-ans (m// n dn)))
  688.         (RETURN (SIMPLIMIT (M// ($EXPAND (M// N SHEUR-ANS))
  689.                     ($EXPAND (M// DN SHEUR-ANS)))
  690.                    VAR
  691.                    VAL))))
  692.      (cond ((and (NOT (AND (EQ VAL '$INF) (EXPP N) (EXPP DN)))
  693.          (SETQ N1 (TRY-LHOSPITAL-quit N DN NIL))
  694.          (NOT (EQ N1 '$UND)))
  695.         (RETURN N1)))
  696.      (THROW 'LIMIT T)))
  697.  
  698. (DEFUN EXPFACTORP (N DN)
  699.        (DO ((LLIST (APPEND (COND ((MTIMESP N) (CDR N))
  700.                 (T (NCONS N)))
  701.               (COND ((MTIMESP DN) (CDR DN))
  702.                 (T (NCONS DN))))
  703.           (CDR LLIST))
  704.         (RATEXP? T)     ;IS EVERY ELEMENT SO FAR A POLY^RAT?
  705.         (ONE-RAT? NIL)  ;IS THERE AT LEAST ONE POLY^RAT WHICH IS NOT
  706.         (FACTOR NIL))   ;A POLY^POLY?
  707.        ((OR (NULL LLIST)
  708.         (NOT RATEXP?))
  709.         (AND RATEXP? ONE-RAT?))
  710.        (SETQ FACTOR (CAR LLIST))
  711.        (SETQ RATEXP? (OR (POLYP FACTOR)
  712.                  (AND (MEXPTP FACTOR)
  713.                   (POLYP (CADR FACTOR))
  714.                   (RATP (CADDR FACTOR) VAR))))
  715.        (SETQ ONE-RAT? (OR ONE-RAT?
  716.                   (AND (MEXPTP FACTOR)
  717.                    (RATP (CADDR FACTOR) VAR)
  718.                    (NOT (POLYP (CADDR FACTOR))))))))
  719.  
  720. (DEFUN EXPFACTOR (N DN VAR)  ;ATTEMPS TO EVALUATE LIMIT BY GROUPING
  721.        (PROG (HIGHEST-DEG)   ; TERMS WITH SIMILAR EXPONENTS.
  722.          (LET ((NEW-EXP (EXPPOLY N)))        ;EXPPOLY UNRATS EXPON
  723.            (SETQ N (CAR NEW-EXP)        ;AND RTNS DEG OF EXPONS
  724.              HIGHEST-DEG (CDR NEW-EXP)))
  725.          (COND ((NULL N) (RETURN NIL)))        ;NIL MEANS EXPON IS NOT
  726.          (LET ((NEW-EXP (EXPPOLY DN)))        ;A RAT FUNC.
  727.            (SETQ DN (CAR NEW-EXP)
  728.              HIGHEST-DEG (MAX HIGHEST-DEG (CDR NEW-EXP))))
  729.          (COND ((NULL DN) (RETURN NIL)))
  730.          (RETURN
  731.           (DO ((ANSWER 1.)
  732.            (DEGREE HIGHEST-DEG (f1- DEGREE))
  733.            (NUMERATOR N)
  734.            (DENOMENATOR DN)
  735.            (NUMFACTORS NIL)
  736.            (DENFACTORS NIL))
  737.           ((= DEGREE -1.)
  738.            (M* ANSWER
  739.                (LIMIT (M// NUMERATOR DENOMENATOR)
  740.                   VAR
  741.                   '$INF
  742.                   'THINK)))
  743.           (LET ((NEWNUMER-FACTOR (GET-NEWEXP&FACTORS
  744.                        NUMERATOR
  745.                        DEGREE
  746.                        VAR)))
  747.             (SETQ NUMERATOR (CAR NEWNUMER-FACTOR)
  748.                   NUMFACTORS (CDR NEWNUMER-FACTOR)))
  749.           (LET ((NEWDENOM-FACTOR (GET-NEWEXP&FACTORS
  750.                        DENOMENATOR
  751.                        DEGREE
  752.                        VAR)))
  753.             (SETQ DENOMENATOR (CAR NEWDENOM-FACTOR)
  754.                   DENFACTORS (CDR NEWDENOM-FACTOR)))
  755.           (SETQ ANSWER (LIMIT (M^ (M* ANSWER
  756.                           (M// NUMFACTORS DENFACTORS))
  757.                       (COND ((> DEGREE 0) VAR)
  758.                         (T 1)))
  759.                       VAR
  760.                       '$INF 'think))
  761.           (COND ((EQ ANSWER '$UND) (RETURN NIL))
  762.             ((zl-MEMBER ANSWER '($INF $MINF 0)) ;Really? ZEROA ZEROB?
  763.              (RETURN ANSWER))
  764.             (T NIL))))))
  765.  
  766. (DEFUN EXPPOLY (EXP)          ;RETURNS EXPRESSION WITH UNRATTED EXPONENTS
  767.        (DO ((FACTOR NIL)
  768.         (HIGHEST-DEG 0)
  769.         (NEW-EXP 1)
  770.         (EXP (COND ((MTIMESP EXP)
  771.             (CDR EXP))
  772.                (T (NCONS EXP)))
  773.          (CDR EXP)))
  774.        ((NULL EXP) (CONS NEW-EXP HIGHEST-DEG))
  775.        (SETQ FACTOR (CAR EXP))
  776.        (SETQ NEW-EXP
  777.          (M* (COND ((or (NOT (MEXPTP FACTOR))
  778.                 (NOT (RATP (CADDR FACTOR) VAR)))
  779.                 FACTOR)
  780.                (T (SETQ HIGHEST-DEG
  781.                     (MAX HIGHEST-DEG
  782.                      (RATDEGREE (CADDR FACTOR))))
  783.                   (m^ (cadr factor) (unrat (caddr factor)))))
  784.              NEW-EXP))))
  785.  
  786. (DEFUN UNRAT (EXP)  ;RETURNS UNRATTED EXPRESION
  787.        (LET ((N-DN (NUMDEN* EXP)))
  788.          (LET ((TEM ($DIVIDE (CAR N-DN) (CDR N-DN))))
  789.            (M+ (CADR TEM)
  790.                (M// (CADDR TEM)
  791.                 (CDR N-DN))))))
  792.  
  793. (DEFUN GET-NEWEXP&FACTORS (EXP DEGREE VAR)       ;RETURNS (CONS NEWEXP FACTORS)
  794.        (DO ((TERMS (COND ((MTIMESP EXP)(CDR EXP)); SUCH THAT
  795.              (T (NCONS EXP)))        ; NEWEXP*FACTORS^(VAR^DEGREE)
  796.            (CDR TERMS))                  ; IS EQUAL TO EXP.        
  797.         (FACTORS 1)                 
  798.         (NEWEXP 1)                          
  799.         (FACTOR NIL))                
  800.        ((NULL TERMS)
  801.         (CONS NEWEXP
  802.           FACTORS))
  803.        (SETQ FACTOR (CAR TERMS))
  804.        (COND ((NOT (MEXPTP FACTOR))
  805.           (COND ((= DEGREE 0)
  806.              (SETQ FACTORS (M* FACTOR FACTORS)))
  807.             (T (SETQ NEWEXP (M* FACTOR NEWEXP)))))
  808.          ((OR (= DEGREE -1)
  809.               (= (RATDEGREE (CADDR FACTOR))
  810.              DEGREE))
  811.           (SETQ FACTORS (M* (M^ (CADR FACTOR)
  812.                     (LEADING-COEF (CADDR FACTOR)))
  813.                     FACTORS)
  814.             NEWEXP (M* (M^ (CADR FACTOR)
  815.                        (M- (CADDR FACTOR)
  816.                        (M* (LEADING-COEF (CADDR FACTOR))
  817.                            (M^ VAR DEGREE))))
  818.                    NEWEXP)))
  819.          (T (SETQ NEWEXP (M* FACTOR NEWEXP))))))
  820.  
  821. (DEFUN LEADING-COEF (RAT)
  822.        (RATLIM (M// RAT (M^ VAR (RATDEGREE RAT)))))
  823.  
  824. (DEFUN RATDEGREE (RAT)
  825.        (LET ((N-DN (NUMDEN* RAT)))
  826.          (f- (DEG (CAR N-DN))
  827.         (DEG (CDR N-DN)))))
  828.  
  829. (DEFUN LIMFACT2 (N D VAR VAL)
  830.        (LET ((N1 (REFLECT0 N VAR VAL))
  831.           (D1 (REFLECT0 D VAR VAL)))
  832.          (COND ((AND (ALIKE1 N N1)
  833.              (ALIKE1 D D1))
  834.             NIL)
  835.            (T (LIMIT (m// N1 D1) VAR VAL 'THINK)))))
  836.  
  837. (DEFUN REFLECT0 (EXP VAR VAL)
  838.        (COND ((ATOM EXP) EXP)
  839.          ((AND (EQ (CAAR EXP) 'MFACTORIAL)
  840.            (LET ((ARGVAL (LIMIT (CADR EXP) VAR VAL 'THINK)))
  841.              (OR (EQ ARGVAL '$MINF)
  842.                  (AND (NUMBERP ARGVAL)
  843.                   (> 0 ARGVAL)))))
  844.           (REFLECT (CADR EXP)))
  845.          (T (CONS (NCONS (CAAR EXP))
  846.               (MAPCAR (FUNCTION
  847.                    (LAMBDA (TERM)
  848.                        (REFLECT0 TERM VAR VAL)))
  849.                   (CDR EXP))))))
  850.  
  851. (DEFUN REFLECT (ARG)
  852.        (M* -1.
  853.        '$%PI
  854.        (M^ (LIST (NCONS 'MFACTORIAL)
  855.              (M+ -1.
  856.              (M* -1. ARG)))
  857.            -1.)
  858.        (M^ (LIST (NCONS '%SIN)
  859.              (M* '$%PI ARG))
  860.            -1.)))
  861.  
  862. (DEFUN LIMFACT (N D)
  863.   (let ((ANS ()))
  864.     (SETQ N (STIRLING0 N)
  865.       D (STIRLING0 D))
  866.     (SETQ ANS ($LIMIT (m// N D) VAR '$INF))
  867.     (COND ((and (atom ans)
  868.        (not (MEMQ ANS '(UND IND ))))  ans)
  869.       ((eq (caar ans) '%limit)  ())
  870.       (t ans))))
  871.  
  872. (DEFUN STIRLING0 (E) 
  873.   (COND ((ATOM E) E)
  874.     ((AND (SETQ E (CONS (CAR E) (MAPCAR 'STIRLING0 (CDR E))))
  875.           NIL))
  876.     ((AND (EQ (CAAR E) '%GAMMA)
  877.           (AMONG VAR (CADR E)))
  878.      (STIRLING (CADR E)))
  879.     ((AND (EQ (CAAR E) 'MFACTORIAL)
  880.           (AMONG VAR (CADR E)))
  881.      (m* (CADR E) (STIRLING (CADR E))))
  882.     (T E)))
  883.  
  884. (DEFUN STIRLING (X)
  885.        (MAXIMA-SUBSTITUTE X '$Z 
  886.             '((MTIMES SIMP)
  887.               ((MEXPT SIMP) 2 ((RAT SIMP) 1 2))
  888.               ((MEXPT SIMP) $%PI ((RAT SIMP) 1 2))
  889.               ((MEXPT SIMP) $Z ((MPLUS SIMP) ((RAT SIMP) -1 2) $Z))
  890.               ((MEXPT SIMP) $%E ((MTIMES SIMP) -1 $Z)))))
  891.  
  892. (DEFUN NO-ERR-SUB (V E &AUX ANS) 
  893.   (LET ((ERRORSW T) (ERRRJFFLAG T) (*ZEXPTSIMP? T))
  894.     ;; (CATCH '(ERRORSW RATERR) (SRATSIMP (SUBIN V E)))
  895.     ;; broken on the Lispm
  896.     (SETQ ANS (CATCH 'ERRORSW
  897.               (CATCH 'RATERR 
  898.                   (SRATSIMP (SUBIN V E)))))
  899.     (COND ((NULL ANS) T)  ; Ratfun package returns NIL for failure.
  900.       (T ANS)))) ; Simplifier returns T for failure.
  901.  
  902. (DEFUN SIMPLIMSUBST (V E) 
  903.        (PROG (ANS)  
  904.          (SETQ ANS (NO-ERR-SUB (RIDOFAB V) E))
  905.          (COND ((EQ ANS T)
  906.             (RETURN NIL))
  907.            ((INVOLVE E '(MFACTORIAL)) NIL)
  908.            ((AND (MEMQ V '($ZEROA $ZEROB)) (=0 ANS))
  909.             (SETQ ANS (BEHAVIOR E VAR V))
  910.             (RETURN (COND ((EQUAL ANS 1) '$ZEROA)
  911.                   ((EQUAL ANS -1) '$ZEROB)
  912.                   (T ANS))))
  913.            (T (RETURN ANS))))) 
  914.  
  915. ;;;returns (cons numerator denomenator)
  916. (defun numden* (e)    
  917.        (let ((e (factor (simplify e)))
  918.          (numer ())  (denom ()))
  919.         (cond ((atom e) 
  920.            (setq numer (cons e numer)))
  921.           ((mtimesp e)
  922.            (mapc 'forq (cdr e)))
  923.           (t (forq e)))
  924.         (cond ((null numer) 
  925.            (setq numer 1.))
  926.           ((null (cdr numer))
  927.            (setq numer (car numer)))
  928.           (t (setq numer (m*l numer))))
  929.         (cond ((null denom) 
  930.            (setq denom 1.))
  931.           ((null (cdr denom))
  932.            (setq denom (car denom)))
  933.           (t (setq denom (m*l denom))))
  934.         (cons (factor numer) (factor denom))))
  935.  
  936. ;;;FACTOR OR QUOTIENT
  937. ;;;Setq's the special vars numer and denom from numden*
  938. (DEFUN FORQ (E)
  939.        (COND ((AND (MEXPTP E)
  940.            (null (pos-neg-p (caddr e))))
  941.           (SETQ DENOM (cons (m^ (CADR E) (m* -1. (CADDR E))) DENOM)))
  942.          (T (SETQ numer (cons E NUMER)))))
  943.  
  944. ;;;Predicate to tell whether an expression is pos,zero or neg as var -> val.
  945. ;;;returns T if pos,zero. () if negative or don't know.
  946. (defun pos-neg-p (exp)
  947.        (let ((ans (limit exp var val 'think)))
  948.         (cond ((and (not (memq ans '($und $ind $infinity)))
  949.             (equal ($imagpart ans) 0))
  950.            (let ((sign (getsignl ans)))
  951.             (cond ((or (equal sign 1)
  952.                    (equal sign 0))
  953.                    t)
  954.                   ((equal sign -1)  nil))))
  955.           (t 'UNKNOWN))))
  956.  
  957. (DECLARE-TOP(UNSPECIAL N DN)) 
  958.  
  959. (SETQ LIMFUNC '(%LOG %SIN %COS %TAN %SINH %COSH %TANH MFACTORIAL
  960.         %ASIN %ACOS %ATAN %ASINH %ACOSH %ATANH)) 
  961.  
  962. (DEFUN EXPP (E) 
  963.        (COND ((RADICALP E VAR) NIL)
  964.          ((MEMQ (CAAR E) LIMFUNC) NIL)
  965.          ((SIMPLEXP E) T)
  966.          ((DO ((E (CDR E) (CDR E)))
  967.           ((NULL E) NIL)
  968.           (AND (EXPP (CAR E)) (RETURN T)))))) 
  969.  
  970. (DEFUN SIMPLEXP (E) 
  971.        (AND (mexptp e)
  972.         (RADICALP (CADR E) VAR)
  973.         (AMONG VAR (CADDR E))
  974.         (RADICALP (CADDR E) VAR))) 
  975.  
  976.  
  977. (DEFUN GCPOWER (A B)
  978.        ($GCD (GETEXP A) (GETEXP B)))
  979.     
  980. (DEFUN GETEXP (EXP)
  981.        (COND ((and (MEXPTP EXP)
  982.            (free (caddr exp) var)
  983.            (eq (ask-integer (caddr exp) '$integer) '$yes))
  984.           (CADDR EXP))
  985.          ((MTIMESP EXP) (GETEXPLIST (CDR EXP)))
  986.          (T 1.)))
  987.  
  988. (DEFUN GETEXPLIST (LIST)
  989.        (COND ((NULL (CDR LIST))
  990.           (GETEXP (CAR LIST)))
  991.          (T ($GCD (GETEXP (CAR LIST))
  992.               (GETEXPLIST (CDR LIST))))))
  993.  
  994. (DEFUN LIMROOT (EXP POWER)
  995.        (COND ((OR (ATOM EXP) (NOT (MEMQ (CAAR EXP) '(MTIMES MEXPT))))
  996.           (LIMROOT (LIST '(MEXPT) EXP 1) POWER)) ;This is strange-JIM.
  997.          ((mexptp exp)  (m^ (CADR EXP)
  998.                 (sRATSIMP (m* (CADDR EXP) (m^ POWER -1.)))))
  999.          (T (m*l (MAPCAR #'(LAMBDA (X)
  1000.                  (LIMROOT X POWER))
  1001.                  (CDR EXP))))))
  1002.  
  1003. ;NUMERATOR AND DENOMENATOR HAVE EXPONENTS WITH GCD OF GCP.
  1004. ;;; Used to call simplimit but some of the transformations used here
  1005. ;;; were not stable w.r.t. the simplifier, so try keeping exponent separate
  1006. ;;; from bas.
  1007.  
  1008. (DEFUN COLEXPT (N DN GCP)
  1009.   (let ((bas (m* (LIMROOT N GCP) (LIMROOT DN (m*  -1. GCP))))
  1010.     (expo gcp) 
  1011.     baslim expolim)
  1012.        (setq baslim (limit bas var val 'think))
  1013.        (setq expolim (limit expo var val 'think))
  1014.        (SIMPLIMexpt bas expo baslim expolim))) 
  1015.  
  1016. ;;; This function will transform an expression such that either all logarithms
  1017. ;;; contain arguments not becoming infinite or are of the form 
  1018. ;;; LOG(LOG( ... LOG(VAR))) This reduction takes place only over the operators
  1019. ;;; MPLUS, MTIMES, MEXPT, and %LOG.
  1020.  
  1021. (DEFUN LOG-RED-CONTRACT (FACS)
  1022.  (DO ((L FACS (CDR L))
  1023.       (CONSTS ())
  1024.       (LOG ()))
  1025.      ((NULL L)
  1026.       (IF LOG (CONS (CADR LOG) (M*L CONSTS))
  1027.       ()))
  1028.      (COND ((FREEOF VAR (CAR L)) (PUSH (CAR L) CONSTS))
  1029.        ((MLOGP (CAR L)) 
  1030.         (IF (NULL LOG) (SETQ LOG (CAR L))
  1031.         (RETURN ())))
  1032.        (T (RETURN ())))))
  1033.  
  1034. (DEFUN LOG-REDUCE (X)
  1035.  (COND ((ATOM X) X)
  1036.        ((FREEOF VAR X) X)
  1037.        ((MPLUSP X)
  1038.     (DO ((L (CDR X) (CDR L))
  1039.          (SUM ())
  1040.          (WEAK-LOGS ())
  1041.          (STRONG-LOGS ())
  1042.          (TEMP))
  1043.         ((NULL L) (M+L `(((%LOG) ,(M*L STRONG-LOGS))
  1044.                  ((%LOG) ,(M*L WEAK-LOGS)) 
  1045.                  ,@SUM)))
  1046.         (SETQ X (LOG-REDUCE (CAR L)))
  1047.         (COND ((MLOGP X)
  1048.            (IF (INFINITYP (LIMIT (CADR X) VAR VAL 'THINK))
  1049.                (PUSH (CADR X) STRONG-LOGS)
  1050.                (PUSH (CADR X) WEAK-LOGS)))
  1051.           ((AND (MTIMESP X) (SETQ TEMP (LOG-RED-CONTRACT (CDR X))))
  1052.            (IF (INFINITYP (LIMIT (CAR TEMP) VAR VAL 'THINK))
  1053.                (PUSH (M^ (CAR TEMP) (CDR TEMP)) STRONG-LOGS)
  1054.                (PUSH (M^ (CAR TEMP) (CDR TEMP)) WEAK-LOGS)))
  1055.           (T (PUSH X SUM)))))
  1056.        ((MTIMESP X)
  1057.     (DO ((L (CDR X) (CDR L))
  1058.          (ANS 1))
  1059.         ((NULL L) ANS)
  1060.         (SETQ ANS ($EXPAND (M* (LOG-REDUCE (CAR L)) ANS)))))
  1061.        ((MEXPTP X) (M^T (LOG-REDUCE (CADR X)) (CADDR X)))
  1062.        ((MLOGP X)
  1063.     (IFN (INFINITYP (LIMIT (CADR X) VAR VAL 'THINK))
  1064.          X
  1065.          (COND ((EQ (CADR X) VAR) X)
  1066.            ((MPLUSP (CADR X))
  1067.             (LET ((STRONGL (MAXI (CDADR X))))
  1068.              (M+ (LOG-REDUCE `((%LOG) ,(CAR STRONGL)))
  1069.                  `((%LOG) ,(M// (CADR X) (CAR STRONGL))))))
  1070.            ((MTIMESP (CADR X))
  1071.             (DO ((L (CDADR X) (CDR L))
  1072.              (ANS 0))
  1073.             ((NULL L) ANS)
  1074.             (SETQ ANS
  1075.                   (M+ (LOG-REDUCE
  1076.                    (SIMPLIFY `((%LOG) ,(LOG-REDUCE (CAR L)))))
  1077.                   ANS))))
  1078.            (T (LET ((RED-LOG (SIMPLIFY `((%LOG)
  1079.                          ,(LOG-REDUCE (CADR X))))))
  1080.                (IF (ALIKE1 RED-LOG X)
  1081.                    X
  1082.                    (LOG-REDUCE RED-LOG)))))))
  1083.        (T X)))
  1084.  
  1085.  
  1086. (defun ratlim (e) 
  1087.        (cond ((memq val '($inf $infinity))
  1088.           (setq e (MAXIMA-SUBSTITUTE (m^t 'x -1) var e)))
  1089.          ((eq val '$minf)
  1090.           (setq e (MAXIMA-SUBSTITUTE (m^t -1 (m^t 'x -1)) var e)))
  1091.          ((eq val '$zerob)
  1092.           (setq e (MAXIMA-SUBSTITUTE (m- 'x) var e)))
  1093.          ((eq val '$zeroa)
  1094.           (setq e (MAXIMA-SUBSTITUTE 'x var e)))
  1095.          ((setq e (MAXIMA-SUBSTITUTE (m+t 'x val) var e))))
  1096.        (let* ((e (let (($ratfac ()))
  1097.               ($rat (sratsimp e) 'x)))
  1098.           ((h n . d) e)
  1099.           (g (genfind h 'x))
  1100.           (nd (lodeg n g))
  1101.           (dd (lodeg d g)))
  1102.          (cond ((and 
  1103.              (setq e
  1104.                (subst var 
  1105.                   'x 
  1106.                   (sratsimp
  1107.                    (m//
  1108.                     ($ratdisrep `(,h ,(locoef n g) . 1))
  1109.                     ($ratdisrep `(,h ,(locoef d g) . 1))))))
  1110.              (greaterp nd dd))
  1111.             (cond ((not (memq val
  1112.                       '($zerob $zeroa $inf $minf)))
  1113.                0)
  1114.               ((not (equal ($imagpart e) 0)) 
  1115.                0)
  1116.               ((null (setq e (getsignl ($realpart e))))
  1117.                0)
  1118.               ((equal e 1) '$zeroa)
  1119.               ((equal e -1) '$zerob)
  1120.               (t 0)))
  1121.            ((equal nd dd) e)
  1122.            ((not (memq val '($zerob $zeroa $infinity $inf $minf)))
  1123.             (throw 'limit t))
  1124.            ((eq val '$infinity)  '$infinity)
  1125.            ((not (equal ($imagpart e) 0)) '$infinity)
  1126.            ((null (setq e (getsignl ($realpart e)))) '$infinity)
  1127.            ((equal e 1) '$inf)
  1128.            ((equal e -1) '$minf)
  1129.            (t 0))))
  1130.  
  1131. (DEFUN LODEG (N X) (IF (OR (ATOM N) (NOT (EQ (CAR N) X))) 0 (LOWDEG (CDR N)))) 
  1132.  
  1133. (DEFUN LOCOEF (N X) (IF (OR (ATOM N) (NOT (EQ (CAR N) X))) N (CAR (LAST N)))) 
  1134.  
  1135.  
  1136. (defun behavior (exp var val)  ; returns either -1, 0, 1.
  1137.   (if (= behavior-count-now behavior-count)
  1138.       0
  1139.       (let ((behavior-count-now (f1+ behavior-count-now)) pair sign)
  1140.     (cond ((real-infinityp val)
  1141.            (setq val (cond ((eq val '$inf) '$zeroa)
  1142.                    ((eq val '$minf) '$zerob)))
  1143.            (setq exp (sratsimp (subin (m^ var -1) exp)))))
  1144.     (cond ((eq val '$infinity) 0)  ; Needs more hacking for complex.
  1145.           ((and (mtimesp exp)
  1146.             (prog2 (setq pair (partition exp var 1))
  1147.                (not (mtimesp (cdr pair)))))
  1148.            (setq sign (getsignl (car pair)))
  1149.            (if (not (fixnump sign))
  1150.            0
  1151.            (f* sign (behavior (cdr pair) var val))))
  1152.           ((and (=0 (no-err-sub (ridofab val) exp))
  1153.             (mexptp exp)
  1154.             (free (caddr exp) var)
  1155.             (equal (getsignl (caddr exp)) 1))
  1156.            (let ((bas (cadr exp)) (expo (caddr exp)))
  1157.          (behavior-expt bas expo)))
  1158.           (t (behavior-by-diff exp var val))))))
  1159.           
  1160. (defun behavior-expt (bas expo)
  1161.   (let ((behavior (behavior bas var val)))
  1162.     (COND ((= behavior 1) 1)
  1163.       ((= behavior 0) 0)
  1164.       ((eq (ask-integer expo '$integer) '$yes)
  1165.        (cond ((eq (ask-integer expo '$even) '$yes) 1)
  1166.          (t behavior)))
  1167.       ((ratnump expo)
  1168.        (cond ((evenp (cadr expo)) 1)
  1169.          ((oddp (caddr expo)) behavior)
  1170.          (t 0)))
  1171.       (t 0))))
  1172.  
  1173. (defun behavior-by-diff (exp var val)
  1174.   (cond ((not (or (eq val '$zeroa) (eq val '$zerob))) 0)
  1175.     (t (let ((old-val val) (old-exp exp))
  1176.          (setq val (ridofab val))
  1177.          (do ((ct 0 (f1+ ct))
  1178.           (exp (sratsimp (sdiff exp var)) (sratsimp (sdiff exp var)))
  1179.           (n () (not n))
  1180.           (ans ()))
  1181.              ((> ct 4) 0) ;This do wins by a return.
  1182.            (setq ans (no-err-sub val exp)) ;Why not do an EVENFN and ODDFN
  1183.                                            ;test here.
  1184.            (cond ((eq ans t)  
  1185.               (return (behavior-numden old-exp var old-val)))
  1186.              ((=0 ans) ()) ;Do it again.
  1187.              (t (setq ans (getsignl ans))
  1188.             (COND (N (RETURN ANS)) 
  1189.                   ((EQUAL ANS 1)
  1190.                    (RETURN (if (EQ old-val '$zeroa) 1 -1)))
  1191.                   ((equal ans -1)
  1192.                    (RETURN (if (EQ old-val '$zeroa) -1 1)))
  1193.                   (t (return 0))))))))))
  1194.  
  1195. (defun behavior-numden (exp var val)
  1196.    (let ((num ($num exp)) (denom ($denom exp)))
  1197.      (cond ((equal denom 1) 0) ;Could be hacked more from here.
  1198.        (t (let ((num-behav (behavior num var val))
  1199.             (denom-behav (behavior denom var val)))
  1200.         (cond ((or (= num-behav 0) (= denom-behav 0)) 0)
  1201.               ((= num-behav denom-behav) 1)
  1202.               (t -1)))))))
  1203.  
  1204. (DEFUN TRY-LHOSPITAL (N D IND)
  1205. ;;;Make one catch for the whole bunch of lhospital trials.
  1206.        (let ((ans (LHOSPITAL-catch N D IND)))
  1207.      (cond ((null ans) ())
  1208.            ((not (free-infp ans)) (simpinf ans))
  1209.            ((not (free-epsilonp ans)) (simpab ans))
  1210.            (t ans))))
  1211.  
  1212. (DEFUN TRY-LHOSPITAL-QUIT (N D IND)
  1213.   (let ((ans (lhospital-catch n d ind)))
  1214.        (cond ((null ans) (THROW 'LIMIT T))
  1215.          ((not (free-infp ans)) (simpinf ans))
  1216.          ((not (free-epsilonp ans)) (simpab ans))
  1217.          (t ans))))
  1218.  
  1219. (defun lhospital-catch (n d ind)
  1220.   (cond ((> 0 lhcount)
  1221.      (setq lhcount $lhospitallim)
  1222.      (throw 'lhospital nil))
  1223.     ((equal lhcount $lhospitallim)
  1224.      (let ((lhcount (m+ lhcount -1)))
  1225.           (catch 'lhospital (lhospital n d ind))))
  1226.     (t (setq lhcount (m+ lhcount -1))
  1227.        (prog1 (lhospital n d ind)
  1228.           (setq lhcount (m+ lhcount 1))))))
  1229. ;If this succeeds then raise LHCOUNT.
  1230.  
  1231.  
  1232. (DEFUN LHOSPITAL (N D IND)
  1233.   (declare (special val lhp?))
  1234.   (IF (MTIMESP N)
  1235.       (SETQ N (m*l (MAPCAR #'(LAMBDA (TERM) (LHSIMP TERM VAR VAL))
  1236.                (CDR N)))))
  1237.   (IF (MTIMESP D)
  1238.       (SETQ D (m*l (MAPCAR #'(LAMBDA (TERM) (LHSIMP TERM VAR VAL))
  1239.                (CDR D)))))
  1240.   (let (((n . d) (lhop-numden n d))
  1241.     const nconst dconst)
  1242.     (SETQ LHP? (AND (NULL IND) (CONS N D)))
  1243.     (desetq (nconst . n) (var-or-const n))
  1244.     (desetq (dconst . d) (var-or-const d))
  1245.     (setq n (sdiff n var) d (sdiff d var))
  1246.     (if (or (not (free n '%derivative)) (not (free d '%derivative)))
  1247.         (throw 'lhospital ()))
  1248.     (setq N (expand-trigs (TANSC n) var))
  1249.     (setq D (expand-trigs (TANSC d) var))
  1250.     (desetq (const . (n . d)) (remove-singularities n d))
  1251.     (setq const (m* const (m// nconst dconst)))
  1252.     (simpinf
  1253.       (COND (IND (let ((ans (LIMIT2 N D VAR VAL)))
  1254.            (if ans (m* const ans))))
  1255.         (t (let ((ans (LIMIT 
  1256.                (cond ((mplusp n)
  1257.                   (m+l (mapcar #'(lambda (x)
  1258.                            (sratsimp (m// x d)))
  1259.                            (cdr n))))
  1260.                  (t ($multthru (sratsimp (M// N D)))))
  1261.                VAR VAL 'think)))
  1262.          (if ans (m* const ans))))))))
  1263.  
  1264. ;Hueristics for picking the right way to express a LHOSPITAL problem.
  1265. (defun lhop-numden (num denom)
  1266.   (declare (special var))
  1267.   (cond ((let ((log-num (involve num '(%log))))
  1268.        (cond ((null log-num) ())
  1269.          ((< (num-of-logs (factor (sratsimp (sdiff (M^ num -1) var))))
  1270.              (num-of-logs (factor (sratsimp (sdiff num var)))))
  1271.           (psetq num (M^ denom -1) denom (m^ num -1)) T)
  1272.          (t t))))
  1273.     ((let ((log-denom (involve denom '(%log))))
  1274.        (cond ((null log-denom) ())
  1275.          ((< (num-of-logs (sratsimp (sdiff (m^ denom -1) var)))
  1276.              (num-of-logs (sratsimp (sdiff denom var))))
  1277.           (psetq denom (M^ num -1) num (m^ denom -1))
  1278.           ;;psetq might return nil but we want to select this clause.
  1279.           T
  1280.           )
  1281.          (t t))))
  1282.     ((let ((exp-num (%einvolve num)))
  1283.           (cond (exp-num (cond ((%e-right-placep exp-num)  t)
  1284.                    (t (psetq num (m^ denom -1)
  1285.                          denom (m^ num -1)) T)))
  1286.             (t ()))))
  1287.     ((let ((exp-den (%einvolve denom)))
  1288.           (cond (exp-den (cond ((%e-right-placep exp-den) t)
  1289.                    (t (psetq num (m^ denom -1)
  1290.                          denom (m^ num -1)) T)))
  1291.             (t ()))))
  1292.     ((let ((scnum (involve num '(%sin))))
  1293.           (cond (scnum (cond ((trig-right-placep '%sin scnum) t)
  1294.                 (t (psetq num (m^ denom -1)
  1295.                       denom (m^ num -1)) T)))
  1296.             (t ()))))
  1297.     ((let ((scden (involve denom '(%sin))))
  1298.           (cond (scden (cond ((trig-right-placep '%sin scden) t)
  1299.                  (t (psetq num (m^ denom -1)
  1300.                        denom (m^ num -1)) T)))
  1301.             (t ()))))
  1302.     ((or (oscip num) (oscip denom)))
  1303.     ((or (polyinx num var ())
  1304.          (polyinx denom var ())))
  1305.     ((or (polyinx (m^ num -1) var ())
  1306.          (polyinx (m^ denom -1) var ()))
  1307.      (psetq num (m^ denom -1) denom (m^ num -1)))
  1308.     ((frac num)
  1309.      (psetq num (m^ denom -1) denom (m^ num -1))))
  1310.   (cons num denom))
  1311.  
  1312. ;i don't know what to do here for some cases, may have to be refined.
  1313. (defun num-of-logs (exp)
  1314.        (cond ((mapatom exp) 0)
  1315.          ((equal (caar exp) '%log) 
  1316.           (m+ 1 (num-of-log-l (cdr exp))))
  1317.          ((and (mexptp exp) (mnump (caddr exp)))
  1318.           (m* (simplify `((mabs) ,(caddr exp)))
  1319.           (num-of-logs (cadr exp))))
  1320.          (t (num-of-log-l (cdr exp)))))
  1321.  
  1322. (defun num-of-log-l (llist)
  1323.   (do ((temp llist (cdr temp)) (ans 0))
  1324.       ((null temp) ans)
  1325.       (setq ans (m+ ans (num-of-logs (car temp))))))
  1326.  
  1327. (defun %e-right-placep (%e-arg)
  1328.   (let ((%e-arg-diff (sdiff %e-arg var)))
  1329.    (cond
  1330.     ((free %e-arg-diff var)) ;simple cases
  1331.     ((or (and (mexptp denom)
  1332.           (equal (cadr denom) -1))
  1333.      (polyinx (m^ denom -1) var ()))  ())
  1334.     ((let ((%e-arg-diff-lim (ridofab (limit %e-arg-diff var val 'think)))
  1335.        (%e-arg-exp-lim (ridofab (limit (m^ '$%e %e-arg) var val 'think))))
  1336.        (cond ((equal %e-arg-diff-lim %e-arg-exp-lim)  t)
  1337.          ((and (mnump %e-arg-diff-lim) (mnump %e-arg-exp-lim))  t)
  1338.          (t ())))))))
  1339.  
  1340. (defun trig-right-placep (trig-type arg)
  1341.   (let ((arglim (ridofab (limit arg var val 'think)))
  1342.     (triglim (ridofab (limit `((,trig-type) ,arg) var val 'think))))
  1343.        (cond ((and (equal arglim 0) (equal triglim 0))  t)
  1344.          ((and (infinityp arglim)  (infinityp triglim))  t)
  1345.          (t ()))))
  1346.  
  1347. ;Takes a numerator and a denominator. If they tries all combinations of
  1348. ;products to try and make a simpler set of subproblems for LHOSPITAL.
  1349. (defun remove-singularities (numer denom)
  1350.   (cond
  1351.    ((or (null numer) (null denom)
  1352.     (atom numer) (atom denom)
  1353.     (not (mtimesp numer)) ;Leave this here for a while.
  1354.     (not (mtimesp denom)))
  1355.     (cons 1 (cons numer denom)))
  1356.    (t 
  1357.     (let (((num-consts . num-vars) (var-or-const numer))
  1358.       ((denom-consts . denom-vars) (var-or-const denom))
  1359.       (const 1))
  1360.      (if (not (mtimesp num-vars))
  1361.          (setq num-vars (list num-vars)) 
  1362.          (setq num-vars (cdr num-vars)))
  1363.      (if (not (mtimesp denom-vars))
  1364.          (setq denom-vars (list denom-vars))
  1365.          (setq denom-vars (cdr denom-vars)))
  1366.      (do ((nl num-vars (cdr nl))
  1367.           (num-list (copy-top-level num-vars ))
  1368.           (den-list denom-vars den-list-temp)
  1369.           (den-list-temp (copy-top-level denom-vars )))
  1370.          ((null nl)  (cons (m* const (m// num-consts denom-consts))
  1371.                    (cons  (m*l num-list) (m*l den-list-temp))))
  1372.        (do ((dl den-list (cdr dl)))
  1373.            ((null dl) t)
  1374.            (cond ((or (%einvolve (car nl))
  1375.               (%einvolve (car nl))) t)
  1376.              (t (let ((lim (catch 'limit
  1377.                    (simpinf 
  1378.                     (simpab (limit (m// (car nl) (car dl))
  1379.                            var val 'think))))))
  1380.                (cond ((or (eq lim t) (eq lim ())
  1381.                       (equal (ridofab lim) 0)
  1382.                       (infinityp lim)
  1383.                       (not (free lim '$inf))
  1384.                       (not (free lim '$minf))
  1385.                       (not (free lim '$infinity))
  1386.                       (not (free lim '$ind))
  1387.                       (not (free lim '$und)))
  1388.                   ())
  1389.                  (t (setq const (m* lim const))    
  1390.                     (setq num-list (zl-DELETE (car nl) 
  1391.                                num-list 1))
  1392.                     (setq den-list-temp
  1393.                       (zl-DELETE (car dl) 
  1394.                           den-list-temp 1))
  1395.                     (return t))))))))))))
  1396.  
  1397. (defun var-or-const (expr)
  1398.   (setq expr ($factor expr))
  1399.   (cond ((atom expr)
  1400.      (cond ((eq expr var) (cons 1 expr))
  1401.            (t (cons expr 1))))
  1402.     ((free expr var) (cons expr 1))
  1403.     ((mtimesp expr)
  1404.      (do ((l (cdr expr) (cdr l))
  1405.           (const 1)  (varl 1)  (lim ()))
  1406.          ((null l)  (cons const varl))
  1407.          (cond ((free (car l) var)
  1408.             (setq const (m* (car l) const)))
  1409.            ((and (setq lim (limit (car l) var val 'think))
  1410.              (free-infp lim)
  1411.              (not (equal (ridofab lim) 0)))
  1412.             (setq const (m* lim const)))
  1413.            (t (setq varl (m* (car l) varl))))))
  1414.     (t (cons 1 expr))))
  1415.  
  1416. (DEFUN LHSIMP (TERM VAR VAL)
  1417.   (COND ((ATOM TERM)  TERM)
  1418.     ((NOT (EQ (CAAR TERM) 'MFACTORIAL))  TERM)
  1419.     (T
  1420.      (LET ((TERM-VALUE (LIMIT TERM VAR VAL 'THINK)))
  1421.        (COND ((NOT (MEMQ TERM-VALUE
  1422.                  '($INF $MINF $UND $IND $INFINITY $ZEROA $ZEROB)))
  1423.           TERM-VALUE)
  1424.          (T TERM))))))
  1425.  
  1426. (DEFUN BYLOG (EXPO BAS)
  1427.        (SIMPLIMEXPT '$%E 
  1428.             (SETQ BAS 
  1429.               (TRY-LHOSPITAL-QUIT (simplify `((%log) ,(TANSC BAS)))
  1430.                           (m^ expo -1)
  1431.                           NIL))
  1432.             '$%E BAS))
  1433.  
  1434. (DEFUN SIMPLIMEXPT (BAS EXPO BL EL) 
  1435.   (COND
  1436.    ((OR (EQ BL '$UND) (EQ EL '$UND)) '$UND)
  1437.    ((ZEROP2 BL)
  1438.     (COND ((EQ EL '$INF) (IF (EQ BL '$ZEROA) BL 0))
  1439.       ((EQ EL '$MINF) (IF (EQ BL '$ZEROA) '$INF '$INFINITY))
  1440.       ((eq EL '$IND) '$ind)
  1441.       ((eq el '$INFINITY) '$UND)
  1442.       ((ZEROP2 EL)  (BYLOG EXPO BAS))
  1443. ;;;Needs more code here for limit(x^(-a),x,0,plus) or minus.
  1444.       ((AND (NOT (MNUMP EL)) (EQ BL '$ZEROB)) (THROW 'LIMIT t))
  1445.       (T (COND ((EQUAL (GETSIGNL EL) -1)
  1446.             (COND ((EQ BL '$ZEROA) '$INF)
  1447.               ((EQ BL '$ZEROB)
  1448.                (COND ((EVEN1 EL) '$INF)
  1449.                  ((eq (ask-integer el '$integer) '$yes)
  1450.                   (cond ((eq (ask-integer el '$even) '$yes)
  1451.                      '$inf)
  1452.                     (t '$minf))))) ;Gotta be ODD.
  1453.               (T (SETQ BAS (BEHAVIOR BAS VAR VAL))
  1454.                  (COND ((EQUAL BAS 1) '$INF)
  1455.                    ((EQUAL BAS -1) '$MINF)
  1456.                    (t (throw 'limit t))))))
  1457.            ((AND (MNUMP EL)
  1458.              (MEMQ BL '($ZEROA $ZEROB)))
  1459.             (COND ((EVEN1 EL) '$ZEROA)
  1460.               ((AND (EQ BL '$ZEROB)
  1461.                 (RATNUMP EL)
  1462.                 (EVENP (CADDR EL))) 0)
  1463.               (T BL)))
  1464.            ((AND (EQUAL (getsignl el) 1)
  1465.              (EQ BL '$ZEROA)) BL)
  1466.            (T 0)))))
  1467.    ((EQ BL '$INFINITY)
  1468.     (COND ((ZEROP2 EL) (BYLOG EXPO BAS))
  1469.       ((EQ EL '$MINF) 0)
  1470.       ((EQ EL '$INF) '$INFINITY)
  1471.       ((MEMQ EL '($INFINITY $IND)) '$UND)
  1472.       ((EQUAL (SETQ EL (GETSIGNl EL)) 1) '$INFINITY)
  1473.       ((NULL EL) '$UND)
  1474.       ((EQUAL EL -1) 0)))
  1475.    ((EQ BL '$INF)
  1476.     (COND ((EQ EL '$INF) '$INF)
  1477.       ((EQUAL EL '$MINF) 0)
  1478.       ((ZEROP2 EL) (BYLOG EXPO BAS))
  1479.       ((MEMQ EL '($INFINITY $IND)) '$UND)
  1480.       (T (COND ((ZEROP (GETSIGNl EL)) 1)
  1481.            ((RATGREATERP 0 EL) '$ZEROA)
  1482.            (T '$INF)))))
  1483.    ((EQ BL '$MINF)
  1484.     (COND ((ZEROP2 EL) (bylog expo bas))
  1485.       ((EQ EL '$INF) '$UND)
  1486.       ((EQUAL EL '$MINF) 0)
  1487. ;;;Why not generalize this. We can ask about the number. -Jim 2/23/81
  1488.       ((MNUMP EL)  (COND ((MNEGP EL)
  1489.                   (COND ((EVEN1 EL) '$ZEROA)
  1490.                     (T (cond
  1491.                     ((eq (ask-integer el '$integer) '$yes)
  1492.                      (cond ((eq (ask-integer el '$even)
  1493.                             '$yes)  '$ZEROA)
  1494.                            (t '$zerob)))
  1495.                     (t 0)))))
  1496.                  (T (COND
  1497.                  ((EVEN1 EL) '$INF)
  1498.                  ((eq (ask-integer el '$integer) '$yes)
  1499.                   (cond ((eq (ask-integer el '$even) '$yes)
  1500.                      '$inf)
  1501.                     (t '$minf)))
  1502.                  (T '$infinity)))))
  1503.       (LOGINPROD? (THROW 'LIP? 'LIP!))
  1504.       (T '$UND)))
  1505.    ((EQUAL (SIMPLIFY (RATDISREP (RIDOFAB BL))) 1)
  1506.     (IF (INFINITYP EL) (BYLOG EXPO BAS) 1))
  1507.    ((AND (EQUAL (RIDOFAB BL) -1)
  1508.      (INFINITYP EL))  '$IND)   ;LB
  1509.    ((EQ BL '$IND)  (COND ((OR (ZEROP2 EL) (INFINITYP EL)) '$UND)
  1510.              ((NOT (EQUAL (GETSIGNl EL) -1)) '$IND)
  1511.              (T '$UND)))
  1512.    ((EQ EL '$INF)  (COND ((ABLESS1 BL)
  1513.               (COND ((EQUAL (GETSIGNl BL) 1) '$ZEROA)
  1514.                 (T 0)))
  1515.              ((EQUAL (GETSIGNL BL) -1) '$INFINITY)
  1516.              (T '$INF)))
  1517.    ((EQ EL '$MINF)  (COND ((NOT (ABLESS1 BL))
  1518.                (COND ((EQUAL (GETSIGNl BL) 1)  '$ZEROA)
  1519.                  (T 0)))
  1520.               ((RATGREATERP 0 BL)  '$INFINITY)
  1521.               (T '$INF)))
  1522.       ((EQ EL '$INFINITY)
  1523.     (if (equal val '$infinity)
  1524.     '$und ;Not enough info to do anything.
  1525.     (let (((real-el . imag-el) (trisplit expo)))
  1526.       (setq real-el (limit real-el var origval nil))
  1527.       (COND ((EQ real-el '$MINF) 0)
  1528.         ((and (EQ real-el '$INF) 
  1529.               (not (equal (ridofab (limit imag-el var origval nil))
  1530.                   0)))   '$INFINITY)
  1531.         (T  '$IND)))))
  1532.  
  1533.    ((EQ EL '$IND)  '$IND)
  1534.    ((ZEROP2 EL) 1)
  1535.    (T (m^ BL EL))))
  1536.  
  1537. (defun even1 (x) 
  1538.   (cond ((numberp x) (and (integerp x) (evenp x)))
  1539.     ((and (mnump x) (evenp (cadr x))))))
  1540.  
  1541. (DEFUN ABLESS1 (BL) 
  1542.        (SETQ BL (NMR BL))
  1543.        (COND ((MNUMP BL)
  1544.           (AND (RATGREATERP 1. BL) (RATGREATERP BL -1.)))
  1545.          (T (EQUAL (GETSIGNl (M1- `((mabs) ,BL))) -1.))))
  1546.  
  1547. (DEFMFUN SIMPLIMIT (EXP VAR VAL) 
  1548.   (COND
  1549.    ((EQ VAR EXP) VAL)
  1550.    ((OR (ATOM EXP) (MNUMP EXP)) EXP)
  1551.    ((AND (NOT (INFINITYP VAL))
  1552.      (NOT (AMONGL '(%SIN %COS %ATANH %COSH %SINH %TANH MFACTORIAL)
  1553.               EXP))
  1554.      (NOT (inf-typep exp))
  1555.      (SIMPLIMSUBST VAL EXP)))
  1556.    ((eq (caar exp) '%limit) (throw 'limit t))
  1557.    ((mplusp exp)  (SIMPLIMPLUS EXP))
  1558.    ((mtimesp exp)  (SIMPLIMTIMES (CDR EXP)))
  1559.    ((mexptp exp)  (SIMPLIMEXPT (CADR EXP) (CADDR EXP)
  1560.                    (LIMIT (CADR EXP) VAR VAL 'THINK)
  1561.                    (LIMIT (CADDR EXP) VAR VAL 'THINK)))
  1562.    ((mlogp exp)  (SIMPLIMLN (CADR EXP)))
  1563.    ((MEMQ (CAAR EXP) '(%SIN %COS))
  1564.     (SIMPLIMSC EXP (CAAR EXP) (LIMIT (CADR EXP) VAR VAL 'THINK)))
  1565.    ((EQ (CAAR EXP) '%TAN) (SIMPLIM%TAN (CADR EXP)))
  1566.    ((EQ (CAAR EXP) '%ATAN) (SIMPLIM%ATAN (LIMIT (CADR EXP) VAR VAL 'THINK)))
  1567.    ((MEMQ (CAAR EXP) '(%SINH %COSH))
  1568.     (SIMPLIMSCH (CAAR EXP) (LIMIT (CADR EXP) VAR VAL 'THINK)))
  1569.    ((EQ (CAAR EXP) 'MFACTORIAL)
  1570.     (SIMPLIMFACT (CADR EXP) VAR VAL (LIMIT (CADR EXP) VAR VAL 'THINK)))
  1571.    ((MEMQ (CAAR EXP) '(%ERF %TANH))
  1572.     (SIMPLIM%ERF-%TANH (CAAR EXP) (CADR EXP)))
  1573.    ((MEMQ (CAAR EXP) '(%ACOS %ASIN))
  1574.     (SIMPLIM%ASIN-%ACOS (CAAR EXP) (LIMIT (CADR EXP) VAR VAL 'THINK)))
  1575.    ((EQ (CAAR EXP) '%ATANH)
  1576.     (SIMPLIM%ATANH (LIMIT (CADR EXP) VAR VAL 'THINK)))
  1577.    ((EQ (CAAR EXP) '%ACOSH)
  1578.     (SIMPLIM%ACOSH (LIMIT (CADR EXP) VAR VAL 'THINK)))
  1579.    ((EQ (CAAR EXP) '%ASINH)
  1580.     (SIMPLIM%ASINH (LIMIT (CADR EXP) VAR VAL 'THINK)))
  1581.    ((eq (caar exp) '%inverse_jacobi_ns)
  1582.     (simplim%inverse_jacobi_ns (LIMIT (CADR EXP) VAR VAL 'THINK) (third exp)))
  1583.    ((eq (caar exp) '%inverse_jacobi_nc)
  1584.     (simplim%inverse_jacobi_nc (LIMIT (CADR EXP) VAR VAL 'THINK) (third exp)))
  1585.    ((eq (caar exp) '%inverse_jacobi_sc)
  1586.     (simplim%inverse_jacobi_sc (LIMIT (CADR EXP) VAR VAL 'THINK) (third exp)))
  1587.    ((eq (caar exp) '%inverse_jacobi_cs)
  1588.     (simplim%inverse_jacobi_cs (LIMIT (CADR EXP) VAR VAL 'THINK) (third exp)))
  1589.    ((eq (caar exp) '%inverse_jacobi_dc)
  1590.     (simplim%inverse_jacobi_dc (LIMIT (CADR EXP) VAR VAL 'THINK) (third exp)))
  1591.    ((eq (caar exp) '%inverse_jacobi_ds)
  1592.     (simplim%inverse_jacobi_ds (LIMIT (CADR EXP) VAR VAL 'THINK) (third exp)))
  1593.    ((and (eq (caar exp) 'mqapply)
  1594.      (eq (subfunname exp) '$li))
  1595.     (simplim$li (subfunsubs exp) (subfunargs exp) val))
  1596.    ((and (eq (caar exp) 'mqapply)
  1597.      (eq (subfunname exp) '$psi))
  1598.     (simplim$psi (subfunsubs exp) (subfunargs exp) val))
  1599.    ((and (eq (caar exp) var)
  1600.      (memq 'array (car exp))
  1601.      (andmapc #'(lambda (sub-exp)
  1602.               (free sub-exp var))
  1603.           (cdr exp)))
  1604.     exp) ;LIMIT(B[I],B,INF); -> B[I]
  1605.    (T (if $limsubst 
  1606.       (let ((head (cond ((memq 'array (car exp))
  1607.                  (list (caar exp) 'array))
  1608.                 (t (list (caar exp))))))
  1609.         (SIMPLIFY (CONS head
  1610.                 (MAPCAR #'(LAMBDA (A) 
  1611.                     (LIMIT A VAR VAL 'THINK))
  1612.                     (CDR EXP)))))))))
  1613.  
  1614. (DEFUN LIMINV (E)
  1615.   (setq e (RESIMPLIFY (SUBST (M// 1 VAR) VAR E)))
  1616.   (let ((new-val (cond ((eq val '$zeroa)  '$inf)
  1617.                ((eq val '$zerob)  '$minf))))
  1618.     (if new-val (let ((preserve-direction t))
  1619.           ($limit e var new-val)) (throw 'limit t))))
  1620.  
  1621. (DEFUN SIMPLIMTIMES (EXP)
  1622.   (PROG (SIGN PROD Y NUM DENOM FLAG ZF FLAG2 EXP1)
  1623.     (SETQ PROD (SETQ NUM (SETQ DENOM 1)) EXP1 EXP)
  1624. LOOP
  1625.     (SETQ Y (LET ((LOGINPROD? (INVOLVE (CAR EXP1) '(%LOG))))
  1626.          (CATCH 'LIP? (LIMIT (CAR EXP1) VAR VAL 'THINK))))
  1627.     (COND ((EQ Y 'LIP!) (RETURN (liminv (cons '(mtimes simp) exp))))
  1628.       ((ZEROP2 Y)
  1629.        (SETQ NUM (M* NUM (CAR EXP1)))
  1630.        (COND ((EQ Y '$ZEROA)
  1631.           (COND (ZF NIL)
  1632.             (T (SETQ ZF 1))))
  1633.          ((EQ Y '$ZEROB)
  1634.           (COND (ZF (SETQ ZF (TIMES -1 ZF)))
  1635.             (T (SETQ ZF -1))))))
  1636.       ((NOT (MEMQ Y '($INF $MINF $INFINITY $IND $UND)))
  1637.        (SETQ PROD (M* PROD Y)))
  1638.       ((EQ Y '$UND) 
  1639.        (RETURN '$UND))
  1640.       ((EQ Y '$IND)
  1641.        (SETQ FLAG2 T))
  1642.       (T (SETQ DENOM (M* DENOM (CAR EXP1)))
  1643.          (COND ((EQ Y '$INFINITY) (SETQ FLAG Y))
  1644.            ((EQ FLAG '$INFINITY) NIL)
  1645.            ((NULL FLAG) (SETQ FLAG Y))
  1646.            ((EQ Y FLAG) (SETQ FLAG '$INF))
  1647.            (T (SETQ FLAG '$MINF)))))
  1648.     (SETQ EXP1 (CDR EXP1))
  1649.     (COND ((NULL EXP1)
  1650.        (COND ((AND (EQUAL NUM 1) (EQUAL DENOM 1))
  1651.           (RETURN (IF FLAG2 '$IND PROD)))
  1652.          ((EQUAL DENOM 1)
  1653.           (COND ((NULL ZF) (RETURN 0))
  1654.             (T (SETQ SIGN (GETSIGNL PROD))
  1655.                (COND ((eq sign 'complex) (RETURN 0))
  1656.                  (SIGN (SETQ ZF (TIMES ZF SIGN))
  1657.                        (RETURN
  1658.                     (COND ((EQUAL ZF 1) '$ZEROA)
  1659.                           ((EQUAL ZF -1) '$ZEROB)
  1660.                           (T 0))))
  1661.                  (T (RETURN 0))))))
  1662.          ((EQUAL NUM 1)
  1663.           (RETURN (COND (FLAG2 '$UND)
  1664.                 ((or (EQUAL (SETQ SIGN (GETSIGNL PROD)) 0)
  1665.                      (null sign))
  1666.                  (throw 'limit t))
  1667.                 ((EQUAL SIGN -1)
  1668.                  (COND ((EQ FLAG '$INF) '$MINF)
  1669.                        ((EQ FLAG '$INFINITY) FLAG)
  1670.                        (T '$INF)))
  1671.                 (T FLAG))))
  1672.          (T (GO DOWN))))
  1673.       (T (GO LOOP)))
  1674.  DOWN
  1675.      (COND ((OR (NOT (AMONG VAR DENOM))
  1676.         (NOT (AMONG VAR NUM)))
  1677.         (THROW 'LIMIT t)))
  1678.      (RETURN (let ((ans (LIMIT2 NUM (M^ DENOM -1) VAR VAL)))
  1679.            (if ans 
  1680.          (SIMPLIMTIMES (LIST PROD ans))
  1681.          (throw 'limit t))))))
  1682.            
  1683. ;;;PUT CODE HERE TO ELIMINATE FAKE SINGULARITIES??
  1684.  
  1685. (defun simplimplus (exp)
  1686.   (cond ((memalike exp simplimplus-problems)
  1687.      (throw 'limit t))
  1688.     (t (unwind-protect 
  1689.         (progn (push exp simplimplus-problems)
  1690.            (let ((ans (catch 'limit (simplimplus1 exp))))
  1691.              (cond ((or (eq ans ())
  1692.                 (eq ans t)
  1693.                 (among '%limit ans))
  1694.                 (let ((new-exp (sratsimp exp)))
  1695.                  (cond ((not (alike1 exp new-exp))
  1696.                     (setq ans
  1697.                           (limit new-exp var val 'think))))
  1698.                  (cond ((or (eq ans ())
  1699.                         (eq ans t))
  1700.                     (throw 'limit t))
  1701.                        (t ans))))
  1702.                (t ans))))
  1703.         (pop simplimplus-problems)))))
  1704.       
  1705. (DEFUN SIMPLIMPLUS1 (EXP) 
  1706.   (PROG (SUM Y INFL INFINITYL MINFL INDL) 
  1707.     (SETQ SUM 0.)
  1708.     (DO ((EXP (CDR EXP) (CDR EXP)) (F))
  1709.         ((OR Y (NULL EXP)) NIL)
  1710.         (SETQ F (LIMIT (CAR EXP) VAR VAL 'THINK))
  1711.         (COND ((EQ F '$UND) (SETQ Y T))
  1712.           ((NOT (MEMQ F '($INF $MINF $INFINITY $IND)))
  1713.            (SETQ SUM (M+ SUM F)))
  1714.           ((EQ F '$IND)  (PUSH (CAR EXP) INDL))
  1715.           (infinityl (throw 'limit t))
  1716. ;;;Don't know what to do with an '$infinity and an $inf or $minf
  1717.           ((EQ F '$INF)  (PUSH (CAR EXP) INFL))
  1718.           ((EQ F '$MINF)  (PUSH (CAR EXP) MINFL))
  1719.           ((eq f '$infinity) 
  1720.            (cond ((or infl minfl)
  1721.               (throw 'limit t))
  1722.              (t (push (car exp) infinityl))))))
  1723.     (COND (Y (RETURN '$UND))
  1724.           ((NOT (OR INFL MINFL INDL INFINITYL))
  1725.            (RETURN (COND ((ATOM SUM)  SUM)
  1726.                  ((or (not (free sum '$zeroa))
  1727.                   (not (free sum '$zerob)))
  1728.                   (simpab SUM))
  1729.                  (T SUM))))
  1730.           (t (cond ((null infinityl)
  1731.             (cond (INFL (COND ((NULL MINFL) (RETURN '$INF))
  1732.                       (T (GO OON))))
  1733.                   (MINFL (RETURN '$MINF))
  1734.                   (T (RETURN '$IND))))
  1735.                (t (setq infl (append infl infinityl))))))
  1736.     
  1737. OON  (SETQ Y (M+L (APPEND MINFL INFL)))
  1738.      (cond ((alike1 exp (setq y (sratsimp (log-reduce (hyperex y)))))
  1739.         (cond ((not (infinityp val))
  1740.            (SETQ INFL (CNV INFL VAL)) ;THIS IS HORRIBLE!!!!
  1741.            (SETQ MINFL (CNV MINFL VAL))))
  1742.         (let ((val '$inf))
  1743.           (COND ((ANDMAPC (FUNCTION (LAMBDA (J) (RADICALP J VAR)))
  1744.                   (APPEND INFL MINFL))
  1745.              (SETQ Y (RHEUR INFL MINFL)))
  1746.             (T (SETQ Y (SHEUR INFL MINFL))))))
  1747.        (t (SETQ Y (LIMIT Y VAR VAL 'THINK))))
  1748.      (COND ((or (eq y ())
  1749.         (eq y t))  (return ()))
  1750.        ((INFINITYP Y)  (RETURN Y))
  1751.        (t (RETURN (M+ SUM Y))))))
  1752.  
  1753. (DEFUN SHEUR0 (N D) 
  1754.   (let ((orig-n n))
  1755.        (COND ((/#ALIKE N D) 1)
  1756.          ((and (free n var)
  1757.            (free d var))
  1758.           (m// n d))
  1759.          (T (SETQ N (CPA N D NIL))
  1760.         (COND ((EQUAL N 1.)
  1761.                (cond ((oscip orig-n)  '$UND)
  1762.                  (t '$inf)))
  1763.               ((EQUAL N -1.)  '$ZEROA)
  1764.               ((EQUAL N 0.)  (m// orig-n d)))))))
  1765.  
  1766.  
  1767. ;;;L1 is a list of INF's and L2 is a list of MINF's. Added together
  1768. ;;;it is indeterminate.
  1769. (DEFUN SHEUR (L1 L2) 
  1770.   (LET ((TERM (SHEUR1 L1 L2)))
  1771.     (COND ((EQUAL TERM '$INF)  '$INF)
  1772.       ((EQUAL TERM '$MINF)   '$MINF)
  1773.       (t (let ((new-num (m+l (mapcar #'(lambda (num-term)
  1774.                          (m// num-term (car l1)))
  1775.                      (append l1 l2)))))
  1776.            (cond ((limit2 new-num (m// 1 (car l1)) var val))))))))
  1777.            
  1778. ;To chicken to throw this code out yet. 
  1779. (comment ((not (alike1 term (m+ (m+l l1) (m+l l2))))
  1780.       (LET ((LIM1 (LIMIT1 TERM VAR VAL))
  1781.         (LIM2 (M+L (MAPCAR #'(LAMBDA (J)
  1782.                        (LIMIT1 (M// J TERM) VAR VAL))
  1783.                    `(,@L1 ,@L2)))))
  1784.            (COND
  1785.         ((OR (AND (EQUAL LIM1 0.)
  1786.               (MEMQ LIM2 '($INF $MINF $UND $IND)))
  1787.              (AND (EQUAL LIM2 0.)
  1788.               (MEMQ LIM1 '($INF $MINF $UND $IND))))
  1789.            (limit2 ($RATSIMP (M// (M+ (M+L L1) (M+L L2)) TERM))
  1790.                (M^ TERM -1) var val))
  1791.         (T (SIMPLIMTIMES `(,LIM1 ,LIM2))))))
  1792.      (t (throw 'limit t)))
  1793.  
  1794. (DEFUN FRAC (EXP) 
  1795.        (COND ((ATOM EXP) NIL)
  1796.          (T (SETQ EXP (NFORMAT EXP))
  1797.         (COND ((AND (EQ (CAAR EXP) 'MQUOTIENT)
  1798.                 (AMONG VAR (CADDR EXP)))
  1799.                T))))) 
  1800.  
  1801. (DEFUN ZEROP2 (Z) (=0 (RIDOFAB Z))) 
  1802.  
  1803. (DEFUN RAISE (A) (M+ A '$ZEROA)) 
  1804.  
  1805. (DEFUN LOWER (A) (M+ A '$ZEROB)) 
  1806.  
  1807. (DEFUN SINCOSHK (EXP1 L SC) 
  1808.        (COND ((EQUAL L 1) (LOWER L))
  1809.          ((EQUAL L -1) (RAISE L))
  1810.          ((AMONG SC L) L)
  1811.          ((MEMQ VAL '($ZEROA $ZEROB)) (SPANGSIDE EXP1 L))
  1812.          (T L))) 
  1813.  
  1814. (DEFUN SPANGSIDE (E L) 
  1815.        (SETQ E (BEHAVIOR E VAR VAL))
  1816.        (COND ((EQUAL E 1) (RAISE L))
  1817.          ((EQUAL E -1) (LOWER L))
  1818.          (T L))) 
  1819.  
  1820. (DEFMFUN RIDOFAB (E) 
  1821.        (IF (AMONG '$ZEROA E) (SETQ E (MAXIMA-SUBSTITUTE 0 '$ZEROA E)))
  1822.        (IF (AMONG '$ZEROB E) (SETQ E (MAXIMA-SUBSTITUTE 0 '$ZEROB E)))
  1823.        E)
  1824.  
  1825. (DEFUN SIMPLERD (EXP) 
  1826.        (AND (mexptp exp)
  1827.         (OR (AND RD* (NOT (AMONG VAR (CADDR EXP))))
  1828.         (MNUMP (CADDR EXP)))
  1829.         (POLYP (CADR EXP)))) 
  1830.  
  1831. (DEFUN BRANCH1 (EXP VAL) 
  1832.        (COND ((POLYP EXP) NIL)
  1833.          ((SIMPLERD EXP) (ZEROP2 (SUBIN VAL (CADR EXP))))
  1834.          (T ;(APPLY 'OR (MAPCAR #'(LAMBDA (J) (BRANCH1 J VAL)) (CDR EXP)))
  1835.           (sloop for v on (cdr exp)
  1836.              when (branch1 (car v) val)
  1837.              do (loop-return v))
  1838.         ;(zl-SOME #'(lambda (j) (branch1 j val)) (the list (cdr exp)))
  1839.         ))) 
  1840.  
  1841. (DEFUN BRANCH (EXP VAL) 
  1842.        (COND ((POLYP EXP) NIL)
  1843.          ((OR (SIMPLERD EXP) (mtimesp exp))
  1844.           (BRANCH1 EXP VAL))
  1845.          ((mplusp exp)
  1846.           ;(ANDMAPC #'(LAMBDA (J) (BRANCH J VAL)) (CDR EXP))
  1847.           (every #'(lambda (j) (branch j val)) (the list (cdr exp))))))
  1848.  
  1849. (DEFUN SER0 (E N D VAL) 
  1850.        (COND ((AND (BRANCH N VAL) (BRANCH D VAL))
  1851.           (SETQ NN* NIL)
  1852.           (SETQ N (SER1 N))
  1853.           (SETQ D (SER1 D))
  1854. ;;;NN* gets set by POFX, called by SER1, to get a list of exponents.
  1855.           (SETQ NN* (RATMIN NN*))
  1856.           (SETQ N (sratsimp (m^ n (m^ var nn*))))
  1857.           (SETQ D (sratsimp (m^ d (m^ var nn*))))
  1858.           (COND ((MEMQ VAL '($ZEROA $ZEROB)) NIL)
  1859.             (T (SETQ VAL 0.)))
  1860.           (RADLIM E N D))
  1861.          (T (TRY-LHOSPITAL-QUIT N D NIL)))) 
  1862.  
  1863. (DEFUN RHEUR (L1 L2) 
  1864.   (PROG (ANS M1 M2) 
  1865.     (SETQ M1 (MAPCAR (FUNCTION ASYMREDU) L1))
  1866.     (SETQ M2 (MAPCAR (FUNCTION ASYMREDU) L2))
  1867.     (SETQ ANS (m+l (APPEND M1 M2)))
  1868.     (COND ((RPTROUBLE (m+l (APPEND L1 L2)))
  1869.        (RETURN (LIMIT (SIMPLIFY (RDSGET (m+l (APPEND L1 L2))))
  1870.               VAR
  1871.               VAL
  1872.               NIL)))
  1873.       ((mplusp ans)  (RETURN (SHEUR M1 M2)))
  1874.       (T (RETURN (LIMIT ANS VAR VAL T)))))) 
  1875.  
  1876. (DEFUN RPTROUBLE (RP) 
  1877.        (NOT (EQUAL (RDDEG RP NIL) (RDDEG (ASYMREDU RP) NIL)))) 
  1878.  
  1879. (DEFUN RADICALP (EXP VAR) 
  1880.        (COND ((POLYinx EXp var ()))
  1881.          ((mexptp exp)  (COND ((EQUAL (CADDR EXP) -1.)
  1882.                    (RADICALP (CADR EXP) VAR))
  1883.                   ((SIMPLERD EXP))))
  1884.          ((MEMQ (CAAR EXP) '(MPLUS MTIMES))
  1885.           (ANDMAPC (FUNCTION (LAMBDA (J) (RADICALP J VAR)))
  1886.                (CDR EXP))))) 
  1887.  
  1888. (DEFUN INVOLVE (E NN*)
  1889.   (declare (special var))
  1890.        (COND ((ATOM E) NIL)
  1891.          ((MNUMP E) NIL)
  1892.          ((AND (MEMQ (CAAR E) NN*) (AMONG VAR (CADR E))) (CADR E))
  1893.          (T (ORMAPC (FUNCTION (LAMBDA (J) (INVOLVE J NN*)))
  1894.             (CDR E)))))
  1895.  
  1896.  
  1897.   
  1898.  
  1899. (DEFUN NOTINVOLVE (EXP NN*) 
  1900.        (COND ((ATOM EXP) T)
  1901.          ((MNUMP EXP) T)
  1902.          ((MEMQ (CAAR EXP) NN*) (NOT (AMONG VAR (CADR EXP))))
  1903.          ((ANDMAPC (FUNCTION (LAMBDA (J) (NOTINVOLVE J NN*)))
  1904.                (CDR EXP))))) 
  1905.  
  1906. (DEFUN SHEUR1 (L1 L2) 
  1907.        (PROG (ANS) 
  1908.          (SETQ L1 (CAR (MAXI L1)))
  1909.          (SETQ L2 (CAR (MAXI L2)))
  1910.          (SETQ ANS (CPA L1 L2 T))
  1911.          (RETURN (COND ((=0 ANS)  (m+  l1 l2))
  1912.                ((EQUAL ANS 1.) '$INF)
  1913.                (T '$MINF))))) 
  1914.  
  1915. (DEFUN ZERO-LIM (CPA-LIST)
  1916.  (DO ((L CPA-LIST (CDR L)))
  1917.      ((NULL L) ())
  1918.      (AND (EQ (CAAR L) 'GEN)
  1919.       (ZEROP2 (LIMIT (CADAR L) VAR VAL 'THINK))
  1920.       (RETURN T))))
  1921.  
  1922. (DEFUN CPA (R1 R2 FLAG) 
  1923.   (let ((t1 r1)
  1924.     (t2 r2))
  1925.     (COND ((ALIKE1 T1 T2)   0.)
  1926.       ((FREE T1 VAR)
  1927.        (COND ((FREE T2 VAR)  0.)
  1928.          (T (LET ((LIM-ANS (LIMIT1 T2 VAR VAL)))
  1929.               (COND ((NOT (MEMQ LIM-ANS '($INF $MINF $UND $IND)))  0.)
  1930.                 (T  -1.))))))
  1931.       ((FREE T2 VAR)
  1932.        (LET ((LIM-ANS (LIMIT1 T1 VAR VAL)))
  1933.          (COND ((NOT (MEMQ LIM-ANS '($INF $MINF $UND $IND)))  0.)
  1934.            (T  1.))))
  1935.       (t (cond ((MTIMESP T1)  (SETQ T1 (CDR T1)))
  1936.            (T (SETQ T1 (LIST T1))))
  1937.          (COND ((MTIMESP T2)  (SETQ T2 (CDR T2)))
  1938.            (T (SETQ T2 (LIST T2))))
  1939.          (SETQ T1 (MAPCAR (FUNCTION ISTRENGTH) T1))
  1940.          (SETQ T2 (MAPCAR (FUNCTION ISTRENGTH) T2))
  1941.          (let ((ans (ISMAX T1))
  1942.            (D (ISMAX T2)))
  1943.            (COND ((or (null ans) (null d)
  1944.               (EQ (CAR ANS) 'GEN) (eq (car d) 'gen))  0.))
  1945.            (if (EQ (CAR ANS) 'VAR)  (SETQ ANS (ADD-UP-DEG T1)))
  1946.            (if (EQ (CAR D) 'VAR)  (SETQ D (ADD-UP-DEG T2)))
  1947.            ;Cant just just compare dominating terms if there are indeterm-
  1948.            ;inates present; e.g. X-X^2*LOG(1+1/X). So check for this.
  1949.            (cond ((OR (ZERO-LIM T1) 
  1950.               (ZERO-LIM T2))  
  1951.               (cpa-indeterm ans d t1 t2 flag))
  1952.              ((ISGREATERP ANS D)  1.)
  1953.              ((ISGREATERP D ANS)  -1.)
  1954.              (t  0)))))))
  1955.  
  1956. (defun cpa-indeterm (ans d t1 t2 flag)
  1957.   (cond ((NOT (EQ (CAR ANS) 'VAR))
  1958.      (SETQ ANS (GATHER ANS T1)  D (GATHER D T2))))
  1959.   (let ((*INDICATOR (AND (EQ (CAR ANS) 'EXP) 
  1960.              FLAG))
  1961.     (test ()))
  1962.     (SETQ TEST (CPA1 ANS D))
  1963.     (COND ((AND (ZEROP1 TEST)
  1964.         (OR (EQUAL ($RADCAN (M// (CADR ANS) (CADR D))) 1.)
  1965.             (AND (POLYP (CADR ANS))
  1966.              (POLYP (CADR D))
  1967.              (EQUAL (LIMIT (M// (CADR ANS) (CADR D)) VAR '$INF 'think)
  1968.                 1.))))
  1969.        (let ((new-term1 (m// t1 (cadr ans)))
  1970.          (new-term2 (m// t2 (cadr d))))
  1971.          (CPA new-term1 new-term2 FLAG)))
  1972.       (t 0))))
  1973.  
  1974. (DEFUN ADD-UP-DEG (STRENGTHL)
  1975.        (DO ((STL STRENGTHL (CDR STL))
  1976.         (POXL)
  1977.         (DEGL))
  1978.        ((NULL STL) (LIST 'VAR (M*L POXL) (M+L DEGL)))
  1979.        (cond ((EQ (CAAR STL) 'VAR)
  1980.           (push (cadar stl) poxl)
  1981.           (push (caddar stl) degl)))))
  1982.  
  1983. (DEFUN CPA1 (P1 P2) 
  1984.        (PROG (FLAG S1 S2) 
  1985.          (COND ((EQ (CAR P1) 'GEN) (RETURN 0.)))
  1986.          (SETQ FLAG (CAR P1))
  1987.          (SETQ P1 (CADR P1))
  1988.          (SETQ P2 (CADR P2))
  1989.          (COND
  1990.           ((EQ FLAG 'VAR)
  1991.            (SETQ S1 (ISTRENGTH P1))
  1992.            (SETQ S2 (ISTRENGTH P2))
  1993.            (RETURN
  1994.         (COND
  1995.          ((ISGREATERP S1 S2) 1.)
  1996.          ((ISGREATERP S2 S1) -1.)
  1997.          (*INDICATOR
  1998.           (SETQ *INDICATOR NIL)
  1999.           (COND
  2000.            ((AND (POLY? P1 VAR) (POLY? P2 VAR))
  2001.             (SETQ P1 (M- P1 P2))
  2002.             (COND ((ZEROP1 P1) 0.)
  2003.               (T (GETSIGNl (HOT-COEF P1)))))
  2004.            (T
  2005.             (SETQ S1
  2006.               (RHEUR (LIST P1)
  2007.                  (LIST (m*t -1 P2))))
  2008.             (COND ((ZEROP2 S1) 0.)
  2009.               ((RATGREATERP S1 0.) 1.)
  2010.               (T -1.)))))
  2011.          (T 0.))))
  2012.           ((EQ FLAG 'EXP)
  2013.            (SETQ P1 (CADDR P1))
  2014.            (SETQ P2 (CADDR P2))
  2015.            (COND ((AND (POLY? P1 VAR) (POLY? P2 VAR))
  2016.               (SETQ P1 (M- P1 P2))
  2017.               (RETURN (COND ((OR (ZEROP1 P1)
  2018.                      (NOT (AMONG VAR P1)))
  2019.                      0.)
  2020.                     (T (GETSIGNl (HOT-COEF P1))))))
  2021.              ((AND (RADICALP P1 VAR) (RADICALP P2 VAR))
  2022.               (SETQ S1
  2023.                 (RHEUR (LIST P1)
  2024.                    (LIST (m*t -1 P2))))
  2025.               (RETURN (COND ((EQ S1 '$INF) 1.)
  2026.                     ((EQ S1 '$MINF) -1.)
  2027.                     ((MNUMP S1)
  2028.                      (COND ((RATGREATERP S1 0.) 1.)
  2029.                        ((RATGREATERP 0. S1) -1.)
  2030.                        (T 0.)))
  2031.                     (T 0.))))
  2032.              (T (RETURN (CPA P1 P2 T)))))
  2033.           ((EQ FLAG 'LOG)
  2034.            (SETQ P1 (TRY-LHOSPITAL (ASYMREDU P1) (ASYMREDU P2) NIL))
  2035.            (RETURN (COND ((ZEROP2 P1) -1.)
  2036.                  ((REAL-INFINITYP P1) 1.)
  2037.                  (T 0.))))))) 
  2038.  
  2039. (SETQ *LIMORDER '(NUM LOG VAR EXP FACT GEN))
  2040.  
  2041. ;;;EXPRESSIONS TO ISGREATERP ARE OF THE FOLLOWING FORMS
  2042. ;;;    ("VAR" POLY DEG)
  2043. ;;;    ("EXP" %E^EXP)
  2044. ;;;    ("LOG" LOG(EXP))
  2045. ;;;    ("FACT"    <A FACTORIAL EXPRESSION>)
  2046. ;;;    ("GEN" <ANY OTHER TYPE OF EXPRESSION>)
  2047.  
  2048. (DEFUN ISGREATERP (A B) 
  2049.   (let ((TA (car a))
  2050.     (TB (car b)))
  2051.     (COND ((or (eq ta 'gen)
  2052.            (eq tb 'gen))  ())
  2053.       ((AND (EQ TA TB) (EQ TA 'VAR))
  2054.        (RATGREATERP (CADDR A) (CADDR B)))
  2055.       ((MEMQ TA (CDR (MEMQ TB *LIMORDER)))))))
  2056.  
  2057. (DEFUN ISMAX (L) 
  2058.   (cond ((null l)  ())
  2059.     ((atom l)   ())
  2060.     ((= (length l) 1)  (car l)) ;If there is only 1 thing give it back.
  2061.     ((andmapc #'(lambda (x) 
  2062.               (not (eq (car x) 'gen))) l)
  2063.               
  2064.      (do ((l1 (cdr l) (cdr l1))
  2065.           (temp-ans (car l))
  2066.           (ans ()))
  2067.          ((null l1) ans)
  2068.        (cond ((isgreaterp temp-ans (car l1)) 
  2069.           (setq ans temp-ans))
  2070.          ((isgreaterp (car l1) temp-ans)
  2071.           (setq temp-ans (car l1))
  2072.           (setq ans temp-ans))
  2073.          (t (setq ans ()))))) 
  2074.     (t ())))
  2075.  
  2076. (DEFUN MAXI (L)   ;RETURNS LIST OF HIGH TERMS
  2077.   (COND ((ATOM L)  NIL)
  2078.     (T (DO ((L (CDR L) (CDR L))
  2079.         (HI-TERM (CAR L))
  2080.         (HI-TERMS (NCONS (CAR L)))
  2081.         (COMPARE NIL))
  2082.            ((NULL L) HI-TERMS)
  2083.          (SETQ COMPARE (LIMIT (M// (CAR L) HI-TERM) VAR val 'THINK))
  2084.          (COND
  2085.           ((INFINITYP COMPARE)
  2086.            (SETQ HI-TERMS (NCONS (SETQ HI-TERM (CAR L)))))
  2087.           ((EQ COMPARE '$UND)
  2088.            (LET ((COMPARE2 (LIMIT (M// HI-TERM (CAR L)) VAR val 'THINK)))
  2089.          (COND ((ZEROP2 COMPARE2)
  2090.             (SETQ HI-TERMS (NCONS (SETQ HI-TERM (CAR L)))))
  2091.                (T NIL))))
  2092.           ((ZEROP2 COMPARE)  NIL)
  2093. ;;;COMPARE IS IND OR FINITE-VALUED
  2094.           (T (SETQ HI-TERMS (APPEND HI-TERMS (NCONS (CAR L))))))))))
  2095.  
  2096. (DEFUN RATMAX (L) 
  2097.        (PROG (ANS) 
  2098.          (COND ((ATOM L) (RETURN NIL)))
  2099.     L1   (SETQ ANS (CAR L))
  2100.     L2   (SETQ L (CDR L))
  2101.          (COND ((NULL L) (RETURN ANS))
  2102.            ((RATGREATERP ANS (CAR L)) (GO L2))
  2103.            (T (GO L1))))) 
  2104.  
  2105. (DEFUN RATMIN (L) 
  2106.        (PROG (ANS) 
  2107.          (COND ((ATOM L) (RETURN NIL)))
  2108.     L1   (SETQ ANS (CAR L))
  2109.     L2   (SETQ L (CDR L))
  2110.          (COND ((NULL L) (RETURN ANS))
  2111.            ((RATGREATERP (CAR L) ANS) (GO L2))
  2112.            (T (GO L1))))) 
  2113.  
  2114. (DEFUN POFX (E) 
  2115.        (COND ((atom e)
  2116.           (cond ((eq e var)
  2117.              (setq nn* (cons 1 nn*)))
  2118.             (t ())))
  2119.          ((OR (MNUMP E) (NOT (AMONG VAR E))) NIL)
  2120.          ((AND (mexptp e) (EQ (CADR E) VAR))
  2121.           (SETQ NN* (CONS (CADDR E) NN*)))
  2122.          ((SIMPLERD E) NIL)
  2123.          (T (MAPC (FUNCTION POFX) (CDR E))))) 
  2124.  
  2125. (DEFUN SER1 (E) 
  2126.        (COND ((MEMQ VAL '($ZEROA $ZEROB)) NIL)
  2127.          (T (SETQ E (SUBIN (M+ VAR VAL) E))))
  2128.        (SETQ E (RDFACT E))
  2129.        (COND ((POFX E) E))) 
  2130.  
  2131. (DEFUN GATHER (IND L) 
  2132.        (PROG (ANS) 
  2133.          (SETQ IND (CAR IND))
  2134.     LOOP (COND ((NULL L)
  2135.             (RETURN (LIST IND (m*l ANS))))
  2136.            ((EQUAL (CAAR L) IND)
  2137.             (SETQ ANS (CONS (CADAR L) ANS))))
  2138.          (SETQ L (CDR L))
  2139.          (GO LOOP)))
  2140.  
  2141. (DEFUN ISTRENGTH (TERM) 
  2142.   (COND ((MNUMP TERM)  (LIST 'NUM TERM))
  2143.     ((ATOM TERM)   (COND ((EQ TERM VAR)
  2144.                   (LIST 'VAR VAR 1.))
  2145.                  (T (LIST 'num TERM))))
  2146.     ((NOT (AMONG VAR TERM))  (LIST 'num TERM))
  2147.     ((RADICALP TERM VAR)  (LIST 'VAR TERM (RDDEG TERM NIL)))
  2148.     ((mplusp TERM)  
  2149.      (let ((temp (ISMAX (MAPCAR (FUNCTION ISTRENGTH) (CDR TERM)))))
  2150.           (cond ((not (null temp))  temp)
  2151.             (t `(gen ,term)))))
  2152.     ((mtimesp term) 
  2153.      (let ((TEMP (MAPCAR (FUNCTION ISTRENGTH) (CDR TERM)))
  2154.            (temp1 ()))
  2155.        (setq temp1 (ismax temp))
  2156.        (COND ((null temp1)  `(gen ,term))
  2157.          ((eq (car temp1) 'log)  `(log ,temp))
  2158.          ((EQ (CAR TEMP1) 'VAR)  (ADD-UP-DEG TEMP))
  2159.          (T `(gen ,TEMP)))))
  2160.     ((AND (mexptp term)
  2161.           (REAL-INFINITYP (LIMIT TERM VAR VAL T)))
  2162.      (COND ((AND (AMONG VAR (CADDR TERM))
  2163.              (MEMQ (CAR (ISTRENGTH (SETQ TERM (LOGRED TERM))))
  2164.                '(VAR EXP FACT))
  2165.              (REAL-INFINITYP (LIMIT TERM VAR VAL T)))
  2166.         (LIST 'EXP (m^ '$%E TERM)))
  2167.            ((NOT (AMONG VAR (CADDR TERM)))
  2168.         (let ((TEMP (ISTRENGTH (CADR TERM))))
  2169.              (cond ((not (alike1 temp term))
  2170.                 (RPLACA (CDR TEMP) TERM)
  2171.                 (AND (EQ (CAR TEMP) 'VAR)
  2172.                  (RPLACA (CDDR TEMP)
  2173.                      (M* (CADDR TEMP) (CADDR TERM))))
  2174.                 TEMP)
  2175.                (t `(gen ,term)))))
  2176.            (T (LIST 'GEN (m^ '$%E TERM)))))
  2177.     ((AND (EQ (CAAR TERM) '%LOG)
  2178.           (REAL-INFINITYP (LIMIT TERM VAR VAL T)))
  2179.      (let ((stren (istrength (cadr term))))
  2180.           (COND ((MEMQ (CAR stren) '(LOG VAR))
  2181.              `(LOG ,TERM))
  2182.             ((eq (car stren) 'exp)
  2183.              (istrength (car (cddadr stren))))
  2184.             (T `(GEN ,TERM)))))
  2185.     ((EQ (CAAR TERM) 'MFACTORIAL)
  2186.      (LIST 'FACT TERM))
  2187.     ((let ((TEMP (HYPEREX TERM)))
  2188.           (AND (NOT (ALIKE1 TERM TEMP))
  2189.                (ISTRENGTH TEMP))))
  2190.     (T (LIST 'GEN TERM))))
  2191.  
  2192. (DEFUN LOGRED (S1) 
  2193.        (OR (AND (EQ (CADR S1) '$%E) (CADDR S1))
  2194.        (m*t (CADDR S1) `((%LOG) ,(CADR S1))))) 
  2195.  
  2196. (DEFUN ASYMREDU (RD) 
  2197.        (COND ((ATOM RD) RD)
  2198.          ((MNUMP RD) RD)
  2199.          ((NOT (AMONG VAR RD)) RD)
  2200.          ((POLYINX RD VAR T))
  2201.          ((SIMPLERD RD)
  2202.           (COND ((EQ (CADR RD) VAR) RD)
  2203.             (T (MABS-SUBST 
  2204.             (FACTOR ($EXPAND (M^ (POLYINX (CADR RD) VAR T)
  2205.                          (CADDR RD))))
  2206.             VAR
  2207.             VAL))))
  2208.          (T (SIMPLIFY (CONS (LIST (CAAR RD))
  2209.                 (MAPCAR (FUNCTION ASYMREDU)
  2210.                     (CDR RD)))))))
  2211.  
  2212. (DEFUN RDFACT (RD) 
  2213.        (let ((DN** ())  (NN** ()))
  2214.         (COND ((ATOM RD) RD)
  2215.           ((MNUMP RD) RD)
  2216.           ((NOT (AMONG VAR RD)) RD)
  2217.           ((POLYP RD)
  2218.            (FACTOR RD))
  2219.           ((SIMPLERD RD)
  2220.            (COND ((EQ (CADR RD) VAR) RD)
  2221.              (T (SETQ DN** (CADDR RD))
  2222.                 (SETQ NN** (FACTOR (CADR RD)))
  2223.                 (COND ((mtimesp nn**)
  2224.                    (m*l (MAPCAR (FUNCTION
  2225.                          (LAMBDA (J)
  2226.                              (m^ j dn**)))
  2227.                         (CDR NN**))))
  2228.                   (T RD)))))
  2229.           (T (SIMPLIFY (CONS (NCONS (CAAR RD))
  2230.                      (MAPCAR #'RDFACT (CDR RD))))))))
  2231.  
  2232. (DEFUN CNV (EXPL VAL) 
  2233.   (MAPCAR #'(LAMBDA (E) 
  2234.           (MAXIMA-SUBSTITUTE (COND ((EQ VAL '$ZEROB)
  2235.                  (m* -1 (m^ var -1)))
  2236.                 ((EQ VAL '$ZEROA)
  2237.                  (m^ var -1))
  2238.                 ((eq val '$minf)
  2239.                  (m* -1 var))
  2240.                 (T (m^ (m+ VAR (m* -1 val)) -1.)))
  2241.               VAR
  2242.               E))
  2243.       EXPL))
  2244.  
  2245. (DEFUN PWTAYLOR (EXP VAR L TERMS) 
  2246.        (PROG (COEF ANS C MC) 
  2247.          (COND ((=0 TERMS) (RETURN NIL)) ((=0 L) (SETQ MC T)))
  2248.          (SETQ C 0.)
  2249.          (GO TAG1)
  2250.     LOOP (SETQ C (ADD1 C))
  2251.          (COND ((OR (GREATERP C 10.) (EQUAL C TERMS))
  2252.             (RETURN (m+l ANS)))
  2253.            (T (SETQ EXP (SDIFF EXP VAR))))
  2254.     TAG1 (SETQ COEF ($RADCAN (SUBIN L EXP)))
  2255.          (COND ((=0 COEF) (SETQ TERMS (ADD1 TERMS)) (GO LOOP)))
  2256.          (SETQ 
  2257.           ANS
  2258.           (APPEND
  2259.            ANS
  2260.            (LIST
  2261.         (m* COEF
  2262.             (m^ `((MFACTORIAL) ,C) -1)
  2263.             (m^ (IF MC VAR (m+t (m*t -1 L) VAR)) C)))))
  2264.          (GO LOOP))) 
  2265.  
  2266. (DEFUN RDSGET (E) 
  2267.        (COND ((POLYP E) E)
  2268.          ((SIMPLERD E) (RDTAY E))
  2269.          (T (CONS (LIST (CAAR E))
  2270.               (MAPCAR (FUNCTION RDSGET) (CDR E)))))) 
  2271.  
  2272. (DEFUN RDTAY (RD) 
  2273.        (COND ($TLIMSWITCH ($RATDISREP ($TAYLOR RD VAR VAL 1.)))
  2274.          (T (LRDTAY RD)))) 
  2275.  
  2276. (DEFUN LRDTAY (RD) 
  2277.        (PROG (VARLIST P C E D $RATFAC)
  2278.          (SETQ VARLIST (NCONS VAR))
  2279.          (SETQ P (RATNUMERATOR (CDR (RATREP* (CADR RD)))))
  2280.          (COND ((LESSP (LENGTH P) 3.) (RETURN RD)))
  2281.          (SETQ E (CADDR RD))
  2282.          (SETQ D (PDEGR P))
  2283.          (SETQ C (m^ VAR (m* D E)))
  2284.          (SETQ D ($RATSIMP (VARINVERT (m* (PDIS P) (m^ VAR (m- D)))
  2285.                       VAR)))
  2286.          (SETQ D (PWTAYLOR (m^ D E) VAR 0. 3.))
  2287.          (RETURN (M* C (VARINVERT D VAR))))) 
  2288.  
  2289. (DEFUN VARINVERT (E VAR) (SUBIN (m^t VAR -1.) E)) 
  2290.  
  2291. (DEFUN DEG (P)
  2292.        (PROG (VARLIST)
  2293.          (SETQ VARLIST (LIST VAR))
  2294.          (RETURN ((LAMBDA ($RATFAC)
  2295.                   (NEWVAR P)
  2296.                   (PDEGR (CADR (RATREP* P))))
  2297.               NIL))))
  2298.  
  2299. (DEFUN RAT-NO-RATFAC (E)
  2300.        ((LAMBDA ($RATFAC)
  2301.         (NEWVAR E)
  2302.         (RATREP* E))
  2303.     NIL))
  2304. (SETQ LOW* NIL) 
  2305.  
  2306. (DEFUN RDDEG (RD LOW*) 
  2307.        (COND ((OR (MNUMP RD)
  2308.           (NOT (AMONG VAR RD))) 
  2309.           0.)
  2310.          ((POLYP RD)
  2311.           (DEG RD))
  2312.          ((SIMPLERD RD)
  2313.           (M* (DEG (CADR RD)) (CADDR RD)))
  2314.          ((mtimesp rd)
  2315.           (ADDN (MAPCAR #'(LAMBDA (J) 
  2316.                 (RDDEG J LOW*))
  2317.                 (CDR RD)) NIL))
  2318.          ((and (mplusp rd)
  2319.            (SETQ RD (ANDMAPCAR #'(LAMBDA (J) (RDDEG J LOW*))
  2320.                        (CDR RD))))
  2321.           (COND (LOW* (RATMIN RD))
  2322.             (T (RATMAX RD)))))) 
  2323.  
  2324. (DEFUN PDEGR (PF) 
  2325.        (COND ((OR (ATOM PF) (NOT (EQ (CAADR (RATF VAR)) (CAR PF))))
  2326.           0.)
  2327.          (LOW* (CADR (REVERSE PF)))
  2328.          (T (CADR PF))))
  2329. ;There is some confusion here. We need to be aware of Branch cuts etc....
  2330. ;when doing this section of code. It is not very carefully done so there
  2331. ;are bugs still lurking. Another misfortune is that LIMIT or its inferiors
  2332. ;somtimes decides to change the limit VAL in midstream. This must be corrected
  2333. ;since LIMIT's interaction with the data base environment must be maintained.
  2334. ;I'm not sure that this code can ever be called with VAL other than $INF but
  2335. ;there is a hook in the first important cond clause to cathc them anyway.
  2336.  
  2337. (DEFUN ASY (N D) 
  2338.   (let ((num-power (rddeg n nil))
  2339.     (den-power (rddeg d nil))
  2340.     (coef ())  (coef-sign ())  (power ()))
  2341.     (setq coef (m// ($RATCOEF N VAR num-power) ($ratcoef d var den-power)))
  2342.     (setq coef-sign (getsignl coef))
  2343.     (setq power (m// num-power den-power))
  2344.     (cond ((eq (ask-integer power '$integer) '$integer)
  2345.        (cond ((eq (ask-integer power '$even) '$even)  '$even)
  2346.          (t   '$odd)))) ;Can be extended from here.
  2347.     (COND ((or (eq val '$minf)
  2348.            (eq val '$zerob)
  2349.            (eq val '$zeroa)
  2350.            (equal val 0))  ()) ;Can be extended to cover some these.
  2351.       ((RATGREATERP den-power num-power)
  2352.        (COND ((EQUAL coef-sign 1.)  '$ZEROA)
  2353.          ((equal coef-sign -1)  '$zerob)
  2354.          ((equal coef-sign 0)   0)
  2355.          (t 0)))
  2356.       ((RATGREATERP num-power den-power)
  2357.        (COND ((EQUAL coef-sign 1.)  '$INF)
  2358.          ((equal coef-sign -1)  '$minf)
  2359.          ((equal coef-sign 0)   0)           ;Questionable!
  2360.          ((null coef-sign)   '$infinity)))
  2361.       (T coef))))
  2362.  
  2363. (DEFUN RADLIM (E N D)
  2364.   (PROG (NL DL) 
  2365.     (COND ((EQ VAL '$INFINITY) (THROW 'LIMIT NIL))
  2366.       ((EQ VAL '$MINF)
  2367.        (SETQ NL (m* var -1))
  2368.        (SETQ N (SUBIN nl n))
  2369.        (SETQ D (SUBIN NL D))
  2370.        (SETQ VAL '$INF))) ;This is the Culprit. Doesn't tell the DATABASE.
  2371.     (COND ((EQ VAL '$INF)
  2372.        (SETQ NL (ASYMREDU N))
  2373.        (SETQ DL (ASYMREDU D))
  2374.        (COND 
  2375.         ((OR (RPTROUBLE N) (RPTROUBLE D))
  2376.          (RETURN (LIMIT (m* (RDSGET N) (m^ (RDSGET D) -1.)) VAR VAL T)))
  2377.         (T (RETURN (ASY NL DL))))))
  2378.     (SETQ NL (LIMIT N VAR VAL T))
  2379.     (SETQ DL (LIMIT D VAR VAL T))
  2380.     (COND ((AND (ZEROP2 NL) (ZEROP2 DL))
  2381.        (COND ((OR (POLYP N) (POLYP D))
  2382.           (RETURN (TRY-LHOSPITAL-QUIT N D T)))
  2383.          (T (RETURN (SER0 E N D VAL)))))
  2384.       (T (RETURN ($RADCAN (RATRAD (m// N D) N D NL DL)))))))
  2385.  
  2386. (DEFUN RATRAD (E N D NL DL) 
  2387.   (PROG (N1 D1) 
  2388.     (COND ((EQUAL NL 0) (RETURN 0))
  2389.           ((ZEROP2 DL)
  2390.            (SETQ N1 NL)
  2391.            (COND ((equal dl 0) (SETQ D1 '$INFINITY)) ;No direction Info.
  2392.              ((EQ DL '$ZEROA)
  2393.               (SETQ D1 '$INF))
  2394.              ((EQUAL (SETQ D (BEHAVIOR D VAR VAL)) 1)
  2395.               (SETQ D1 '$INF))
  2396.              ((EQUAL D -1) (SETQ D1 '$MINF))
  2397.              (T (THROW 'LIMIT NIL))))
  2398.           ((ZEROP2 NL)
  2399.            (SETQ D1 DL)
  2400.            (COND ((EQUAL (SETQ N (BEHAVIOR N VAR VAL)) 1)
  2401.               (SETQ N1 '$ZEROA))
  2402.              ((EQUAL N -1) (SETQ N1 '$ZEROB))
  2403.              (T (SETQ N1 0))))
  2404.           (T (RETURN ($RADCAN (RIDOFAB (SUBIN VAL E))))))
  2405.     (RETURN (SIMPLIMTIMES (LIST N1 D1)))))
  2406.  
  2407. (DEFUN SIMPLIMLN (ARG)
  2408.  (LET* ((ARGLIM (LIMIT ARG VAR VAL 'THINK))
  2409.     (REAL-LIM (RIDOFAB ARGLIM)))
  2410.        (IF (=0 REAL-LIM)
  2411.        (cond ((eq arglim '$ZEROA)  '$MINF)
  2412.          ((eq arglim '$ZEROB)  '$INFINITY)
  2413.          (T (LET ((DIR (BEHAVIOR ARG VAR VAL)))
  2414.              (COND ((EQUAL DIR 1) '$MINF)
  2415.                    ((EQUAL DIR -1) '$INFINITY)
  2416.                    (T (THROW 'LIMIT T))))))
  2417.        (cond ((eq arglim '$INF) '$INF)
  2418.          ((memq arglim '($MINF $INFINITY)) '$INFINITY)
  2419.          ((memq arglim '($IND $UND)) '$UND)
  2420.          ((equal arglim 1)
  2421.           (let ((dir (behavior arg var val)))
  2422.             (if (equal dir 1) '$zeroa 0)))
  2423.          (T (SIMPLIFY `((%LOG) ,REAL-LIM)))))))
  2424.  
  2425. (DEFUN SIMPLIMFACT (EXP VAR VAL ARG)
  2426.        (COND ((EQ ARG '$INF) '$INF)
  2427.          ((MEMQ ARG '($MINF $INFINITY $UND $IND)) '$UND)
  2428.          ((AND (MAXIMA-INTEGERP ARG) (> 0 ARG))
  2429.           (LET ((DIR (LIMIT (m+ exp (m* arg -1)) VAR VAL 'THINK))
  2430.              (EVENP (MAXIMA-INTEGERP (QUOTIENT ARG 2.0))))
  2431.             (COND ((OR (AND EVENP
  2432.                     (EQ DIR '$ZEROA))
  2433.                    (AND (NOT EVENP)
  2434.                     (EQ DIR '$ZEROB)))
  2435.                '$MINF)
  2436.               ((OR (AND EVENP
  2437.                     (EQ DIR '$ZEROB))
  2438.                    (AND (NOT EVENP)
  2439.                     (EQ DIR '$ZEROA)))
  2440.                '$INF)
  2441.               (T (THROW 'LIMIT NIL)))))
  2442.           (T (SIMPFACT (LIST '(MFACTORIAL) (RIDOFAB ARG)) 1 NIL)))) 
  2443.  
  2444. (defun simplim%erf-%tanh (fn arg) 
  2445.   (let ((arglim (limit arg var val 'think)))
  2446.     (cond ((eq arglim '$inf) 1)
  2447.       ((eq arglim '$minf) -1)
  2448.       ((eq arglim '$infinity)
  2449.        (let (((rpart . ipart) (trisplit arg))
  2450.          (ans ()) (rlim ()))
  2451.          (setq rlim (limit rpart var origval 'think))
  2452.          (cond ((eq fn '%tanh)
  2453.             (cond ((equal rlim '$inf) 1)
  2454.               ((equal rlim '$minf) -1)))
  2455.            ((eq fn '%erf)
  2456.             (setq ans
  2457.               (limit (m* rpart (m^t ipart -1)) var origval 'think))
  2458.             (setq ans ($asksign (m+ `((mabs) ,ans) -1)))
  2459.             (cond ((or (eq ans '$pos) (eq ans '$zero))
  2460.                (cond ((eq rlim '$inf) 1)
  2461.                  ((eq rlim '$minf) -1)
  2462.                  (t '$und)))
  2463.               (t '$und))))))
  2464.       ((eq arglim '$und) '$und)
  2465.       ((memq arglim '($zeroa $zerob $ind)) arg)
  2466. ;;;Ignore tanh(%pi/2*%I) and multiples of the argument.
  2467.       (t (simplify (list (ncons fn) arg))))))
  2468.  
  2469. (DEFUN SIMPLIM%ATAN (EXP1) 
  2470.        (COND ((ZEROP2 EXP1) EXP1)
  2471.          ((EQ EXP1 '$INF) HALF%PI)
  2472.          ((EQ EXP1 '$MINF)
  2473.           (m*t -1. HALF%PI))
  2474.          (T `((%ATAN) ,EXP1)))) 
  2475.  
  2476. (DEFUN SIMPLIMSCH (SCH ARG) 
  2477.        (COND ((REAL-INFINITYP ARG)
  2478.           (COND ((EQ SCH '%SINH) ARG) (T '$INF)))
  2479.          ((EQ ARG '$INFINITY) '$INFINITY)
  2480.          ((EQ ARG '$UND) '$UND)
  2481.          (T (LET (($EXPONENTIALIZE T))
  2482.           (RESIMPLIFY (LIST (NCONS SCH) (RIDOFAB ARG))))))) 
  2483.  
  2484. (DEFUN SIMPLIMSC (EXP FN ARG) 
  2485.        (COND ((MEMQ ARG '($INF $MINF $IND)) '$IND)
  2486.          ((MEMQ ARG '($UND $INFINITY)) '$UND)
  2487.          ((MEMQ ARG '($ZEROA $ZEROB))
  2488.           (COND ((EQ FN '%SIN) ARG)
  2489.             (T (m+ 1 '$zerob))))
  2490.          ((SINCOSHK EXP
  2491.             (SIMPLIFY (LIST (NCONS FN) (RIDOFAB ARG)))
  2492.             FN))))
  2493.  
  2494. (DEFUN SIMPLIM%TAN (ARG) 
  2495.    (let ((arg1 (ridofab (limit arg var val 'think))))
  2496.      (COND
  2497.       ((MEMQ ARG1 '($INF $MINF $INFINITY $IND $UND))  '$UND)
  2498.       ((PIP ARG1)  
  2499.        (let ((C (TRIGRED (PIP ARG1))))
  2500.      (COND ((not (equal ($imagpart arg1) 0)) '$infinity)
  2501.            ((AND (EQ (CAAR C) 'RAT)
  2502.              (EQUAL (CADDR C) 2) 
  2503.              (GREATERP (CADR C) 0))
  2504.         (SETQ ARG1 (BEHAVIOR ARG VAR VAL))
  2505.         (COND ((= ARG1 1) '$INF)
  2506.               ((= ARG1 -1) '$MINF)
  2507.               (T '$UND)))
  2508.            ((AND (EQ (CAAR C) 'RAT)
  2509.              (EQUAL (CADDR C) 2) 
  2510.              (LESSP (CADR C) 0))
  2511.         (SETQ ARG1 (BEHAVIOR ARG VAR VAL))
  2512.         (COND ((= ARG1 1) '$MINF)
  2513.               ((= ARG1 -1) '$INF)
  2514.               (T '$UND)))
  2515.            (T (throw 'limit ())))))
  2516.       ((equal arg1 0)
  2517.        (setq arg1 (behavior arg var val))
  2518.        (cond ((equal arg1 1) '$zeroa)
  2519.          ((equal arg1 -1) '$zerob)
  2520.          (t 0)))
  2521.       (t (SIMP-%TAN (LIST '(%TAN) ARG1) 1. NIL)))))
  2522.  
  2523. (DEFUN SIMPLIM%ASINH (ARG) 
  2524.        (COND ((MEMQ ARG '($INF $MINF $ZEROA $ZEROB $IND $UND))
  2525.           ARG)
  2526.          ((EQ ARG '$INFINITY) '$UND)
  2527.          (T (SIMPLIFY (LIST '(%ASINH) (RIDOFAB ARG)))))) 
  2528.  
  2529. (DEFUN SIMPLIM%ACOSH (ARG) 
  2530.        (COND ((EQUAL (RIDOFAB ARG) 1.) '$ZEROA)
  2531.          ((EQ ARG '$INF) ARG)
  2532.          ((EQ ARG '$MINF) '$INFINITY)
  2533.          ((MEMQ ARG '($UND $IND $INFINITY)) '$UND)
  2534.          (T (SIMPLIFY (LIST '(%ACOSH) (RIDOFAB ARG))))))
  2535.  
  2536. (DEFUN SIMPLIM%ATANH (ARG) 
  2537.        (COND ((ZEROP2 ARG) ARG)
  2538.          ((MEMQ ARG '($IND $UND $INFINITY $MINF $INF))
  2539.           '$UND)
  2540.          ((EQUAL (SETQ ARG (RIDOFAB ARG)) 1.) '$INF)
  2541.          ((EQUAL ARG -1.) '$MINF)
  2542.          (T (SIMPLIFY (LIST '(%ATANH) ARG))))) 
  2543.  
  2544. (DEFUN SIMPLIM%ASIN-%ACOS (FN ARG) 
  2545.        (COND ((MEMQ ARG '($UND $IND $INF $MINF $INFINITY))
  2546.           '$UND)
  2547.          ((AND (EQ FN '%ASIN)
  2548.            (MEMQ ARG '($ZEROA $ZEROB)))
  2549.           ARG)
  2550.          (T (SIMPLIFY (LIST (NCONS FN) (RIDOFAB ARG))))))
  2551.  
  2552. (defun simplim$li (order arg val)
  2553.   (cond ((and (not (equal (length order) 1))
  2554.           (not (equal (length arg) 1)))  (throw 'limit ()))
  2555.     (t (setq order (car order) arg (car arg))))
  2556.   (cond ((not (equal order 2))  (throw 'limit ()))
  2557.     (t (let (((rpart . ipart) (trisplit arg)))
  2558.          (cond ((not (equal ipart 0))  (throw 'limit ()))
  2559.            (t (setq rpart (limit rpart var val 'think))
  2560.               (cond ((eq rpart '$zeroa)  '$zeroa)
  2561.                 ((eq rpart '$zerob)  '$zerob)
  2562.                 ((eq rpart '$minf)  '$minf)
  2563.                 ((eq rpart '$inf)  '$infinity)
  2564.                 (t (simplify (subfunmake '$li (list order)
  2565.                              (list rpart)))))))))))
  2566.  
  2567. (defun simplim$psi (order arg val)
  2568.   (cond ((and (not (equal (length order) 1))
  2569.           (not (equal (length arg) 1)))  (throw 'limit ()))
  2570.     (t (setq order (car order) arg (car arg))))
  2571.   (cond ((not (equal order 0))  (throw 'limit ()))
  2572.     (t (let (((rpart . ipart) (trisplit arg)))
  2573.          (cond ((not (equal ipart 0))  (throw 'limit ()))
  2574.            (t (setq rpart (limit rpart var val 'think))
  2575.               (cond ((eq rpart '$zeroa)  '$minf)
  2576.                 ((eq rpart '$zerob)  '$inf)
  2577.                 ((eq rpart '$inf)  '$inf)
  2578.                 ((eq rpart '$minf)   '$und)
  2579.                 ((equal (getsignl rpart) -1)  (throw 'limit ()))
  2580.                 (t (simplify (subfunmake '$psi (list order)
  2581.                              (list rpart)))))))))))
  2582.  
  2583. (defun simplim%inverse_jacobi_ns (arg m)
  2584.   (cond ((or (eq arg '$inf) (eq arg '$minf))
  2585.      0)
  2586.     (t
  2587.      `((%inverse_jacobi_ns) ,arg ,m))))
  2588.  
  2589. (defun simplim%inverse_jacobi_nc (arg m)
  2590.   (cond ((or (eq arg '$inf) (eq arg '$minf))
  2591.      `((%elliptic_kc) ,m))
  2592.     (t
  2593.      `((%inverse_jacobi_nc) ,arg ,m))))
  2594.  
  2595. (defun simplim%inverse_jacobi_sc (arg m)
  2596.   (cond ((or (eq arg '$inf) (eq arg '$minf))
  2597.      `((%elliptic_kc) ,m))
  2598.     (t
  2599.      `((%inverse_jacobi_sc) ,arg ,m))))
  2600.  
  2601. (defun simplim%inverse_jacobi_dc (arg m)
  2602.   (cond ((or (eq arg '$inf) (eq arg '$minf))
  2603.      `((%elliptic_kc) ,m))
  2604.     (t
  2605.      `((%inverse_jacobi_dc) ,arg ,m))))
  2606.  
  2607. (defun simplim%inverse_jacobi_cs (arg m)
  2608.   (cond ((or (eq arg '$inf) (eq arg '$minf))
  2609.      0)
  2610.     (t
  2611.      `((%inverse_jacobi_cs) ,arg ,m))))
  2612.  
  2613. (defun simplim%inverse_jacobi_ds (arg m)
  2614.   (cond ((or (eq arg '$inf) (eq arg '$minf))
  2615.      0)
  2616.     (t
  2617.      `((%inverse_jacobi_ds) ,arg ,m))))
  2618.  
  2619.  
  2620.  
  2621. (COMMENT MORE FUNCTIONS FOR LIMIT TO HANDLE)
  2622.  
  2623. (DEFUN LFIBTOPHI (E)
  2624.        (COND ((NOT (INVOLVE E '($FIB))) E)
  2625.          ((EQ (CAAR E) '$FIB)
  2626.           ((LAMBDA (LNORECURSE)
  2627.                ($FIBTOPHI (LIST '($FIB) (LFIBTOPHI (CADR E)))))
  2628.            T))
  2629.          (T (CONS (CAR E)
  2630.               (MAPCAR (FUNCTION LFIBTOPHI) (CDR E))))))
  2631.  
  2632. ;;;     FOLLOWING CODE MAKES $LDEFINT WORK
  2633.  
  2634. (DEFMFUN $LDEFINT (EXP VAR LL UL &aux $logabs ans a1 a2)
  2635.    (SETQ $LOGABS T ANS (SININT EXP VAR) 
  2636.      A1 ($LIMIT ANS VAR UL '$MINUS) 
  2637.      A2 ($LIMIT ANS VAR LL '$PLUS))
  2638.    (AND (MEMQ A1 '($INF $MINF $INFINITY $UND $IND))
  2639.     (SETQ A1 (NOUNLIMIT ANS VAR UL)))
  2640.    (AND (MEMQ A2 '($INF $MINF $INFINITY $UND $IND))
  2641.     (SETQ A2 (NOUNLIMIT ANS VAR LL)))
  2642.    ($EXPAND (M- A1 A2)))
  2643.  
  2644. (DEFUN NOUNLIMIT (EXP VAR VAL) 
  2645.        (SETQ EXP (RESTORELIM EXP))
  2646.        (NCONC (LIST '(%LIMIT) EXP VAR (RIDOFAB VAL))
  2647.           (COND ((EQ VAL '$ZEROA) '($PLUS))
  2648.             ((EQ VAL '$ZEROB) '($MINUS))))) 
  2649.  
  2650. (DEFUN HIDE (EXP) 
  2651.   (COND ((ATOM EXP) EXP)
  2652.     ((let ((FUNC (MEMQ (CAAR EXP) '(%INTEGRATE %LIMIT %DERIVATIVE %SUM))))
  2653.           (cond ((not (null func))
  2654.              (HIDELIM EXP (CAR FUNC)))
  2655.             (t ()))))
  2656.     (T (CONS (CAR EXP) (MAPCAR 'HIDE (CDR EXP))))))
  2657.  
  2658. (DEFUN HIDELIM (EXP FUNC) 
  2659.        (COND ((OR (EQ FUNC '%INTEGRATE) (EQ FUNC '%SUM))
  2660.           (SETQ FUNC (GENSYM))
  2661.           (PUTPROP FUNC
  2662.                (COND ((OR (NULL (CDDDR EXP))
  2663.                   (NOT (EQ VAR (third EXP))))
  2664.                   (HIDELIMA EXP))
  2665.                  ((AND (NOT (AMONG VAR (fourth EXP)))
  2666.                    (NOT (AMONG VAR (fifth EXP))))
  2667.                   EXP)
  2668.                  (T (NOUNLIMIT EXP VAR VAL)))
  2669.                'LIMITSUB))
  2670.          ((EQ FUNC '%LIMIT)
  2671.           (SETQ FUNC (GENSYM))
  2672.           (PUTPROP FUNC
  2673.                (COND ((EQ VAR (fourth EXP))
  2674.                   (NCONC (LIST (first EXP)
  2675.                        (second EXP)
  2676.                        (third EXP))
  2677.                      (SUBST VAL VAR (CDDDR EXP))))
  2678.                  ((EQ VAR (CADDR EXP)) EXP)
  2679.                  (T (HIDELIMA EXP)))
  2680.                'LIMITSUB))
  2681.          (T (SETQ FUNC (GENSYM))
  2682.         (PUTPROP FUNC (HIDELIMA EXP) 'LIMITSUB)))
  2683.        FUNC) 
  2684.  
  2685. (DEFUN HIDELIMA (E) 
  2686.        (COND ((AMONG VAR E) (NOUNLIMIT E VAR VAL)) (T E))) 
  2687.  
  2688. ;;;Used by Defint also.
  2689. (DEFUN OSCIP (E)
  2690.        (OR (INVOLVE E '(%SIN %COS %TAN))
  2691.        (AMONG '$%I (%EINVOLVE E))))
  2692.  
  2693. (DEFUN %EINVOLVE (E) (COND ((AMONG '$%E E) (%EINVOLVE01 E)))) 
  2694.  
  2695. (DEFUN %EINVOLVE01 (E)
  2696.        (COND ((ATOM E) NIL)
  2697.          ((MNUMP E) NIL)
  2698.          ((AND (mexptp E)
  2699.            (EQ (CADR E) '$%E)
  2700.            (AMONG VAR (CADDR E)))
  2701.           (CADDR E))
  2702.          (T (ORMAPC (FUNCTION %EINVOLVE) (CDR E))))) 
  2703.  
  2704.  
  2705. #-NIL
  2706. (DECLARE-TOP(UNSPECIAL *INDICATOR NN* DN* EXP VAR VAL
  2707.             ORIGVAL *LIMORDER TAYLORED 
  2708.             $TLIMSWITCH LOGCOMBED LHP? LHCOUNT $RATFAC))
  2709.